Merge branch 'master' of http://darcs.haskell.org//ghc
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 30 Apr 2012 12:43:33 +0000 (13:43 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 30 Apr 2012 12:43:33 +0000 (13:43 +0100)
85 files changed:
aclocal.m4
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/deSugar/DsMeta.hs
compiler/ghci/RtClosureInspect.hs
compiler/iface/IfaceType.lhs
compiler/iface/LoadIface.lhs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/TargetReg.hs
compiler/prelude/primops.txt.pp
compiler/rename/RnEnv.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplMonad.lhs
compiler/simplCore/SimplUtils.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/types/InstEnv.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/utils/Platform.hs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Exp.hs
config.guess
configure.ac
docs/users_guide/using.xml
ghc.mk
ghc/InteractiveUI.hs
ghc/hschooks.c
includes/Rts.h
includes/mkDerivedConstants.c
includes/rts/Hooks.h
includes/rts/Messages.h
includes/rts/Types.h
includes/stg/MiscClosures.h
includes/stg/Types.h
mk/validate-settings.mk
rts/Capability.c
rts/Disassembler.c
rts/Linker.c
rts/PrimOps.cmm
rts/Printer.c
rts/ProfHeap.c
rts/RtsFlags.c
rts/RtsStartup.c
rts/Stats.c
rts/Stats.h
rts/Task.c
rts/Ticky.c
rts/Trace.c
rts/eventlog/EventLog.c
rts/eventlog/EventLog.h
rts/hooks/MallocFail.c
rts/hooks/OutOfHeap.c
rts/hooks/StackOverflow.c
rts/sm/Sanity.c
rts/sm/Scav.c
rts/win32/IOManager.c
rts/win32/OSMem.c
rules/build-package-data.mk
rules/distdir-way-opts.mk
utils/ghc-cabal/ghc.mk
utils/ghc-pkg/ghc.mk

index 5652185..c196bdf 100644 (file)
@@ -171,7 +171,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
             ;;
         arm)
             GET_ARM_ISA()
-            test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
+            test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT, armABI = \$ARM_ABI}\""
             ;;
         alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
             test -z "[$]2" || eval "[$]2=ArchUnknown"
index 64ef6b6..8d46b7e 100644 (file)
@@ -170,10 +170,9 @@ mkUnfolding src top_lvl is_bottoming expr
                    uf_is_value   = exprIsHNF        expr,
                     uf_is_conlike = exprIsConLike    expr,
                    uf_expandable = exprIsExpandable expr,
-                   uf_is_cheap   = is_cheap,
+                   uf_is_cheap   = exprIsCheap      expr,
                    uf_guidance   = guidance }
   where
-    is_cheap = exprIsCheap expr
     (arity, guidance) = calcUnfoldingGuidance expr
        -- Sometimes during simplification, there's a large let-bound thing     
        -- which has been substituted, and so is now dead; so 'expr' contains
index df72778..8ec132f 100644 (file)
@@ -1329,50 +1329,9 @@ locallyBoundR rn_env v = inRnEnvR rn_env v
 %************************************************************************
 
 \begin{code}
-coreBindsSize :: [CoreBind] -> Int
-coreBindsSize bs = foldr ((+) . bindSize) 0 bs
-
-exprSize :: CoreExpr -> Int
--- ^ A measure of the size of the expressions, strictly greater than 0
--- It also forces the expression pretty drastically as a side effect
--- Counts *leaves*, not internal nodes. Types and coercions are not counted.
-exprSize (Var v)         = v `seq` 1
-exprSize (Lit lit)       = lit `seq` 1
-exprSize (App f a)       = exprSize f + exprSize a
-exprSize (Lam b e)       = varSize b + exprSize e
-exprSize (Let b e)       = bindSize b + exprSize e
-exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
-exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e
-exprSize (Tick n e)      = tickSize n + exprSize e
-exprSize (Type t)        = seqType t `seq` 1
-exprSize (Coercion co)   = seqCo co `seq` 1
-
-tickSize :: Tickish Id -> Int
-tickSize (ProfNote cc _ _) = cc `seq` 1
-tickSize _ = 1 -- the rest are strict
-
-varSize :: Var -> Int
-varSize b  | isTyVar b = 1
-           | otherwise = seqType (idType b)             `seq`
-                         megaSeqIdInfo (idInfo b)       `seq`
-                         1
-
-varsSize :: [Var] -> Int
-varsSize = sum . map varSize
-
-bindSize :: CoreBind -> Int
-bindSize (NonRec b e) = varSize b + exprSize e
-bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
-
-pairSize :: (Var, CoreExpr) -> Int
-pairSize (b,e) = varSize b + exprSize e
-
-altSize :: CoreAlt -> Int
-altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
-\end{code}
-
-\begin{code}
-data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
+data CoreStats = CS { cs_tm :: Int    -- Terms
+                    , cs_ty :: Int    -- Types
+                    , cs_co :: Int }  -- Coercions
 
 
 instance Outputable CoreStats where 
@@ -1428,6 +1387,54 @@ coStats :: Coercion -> CoreStats
 coStats co = zeroCS { cs_co = coercionSize co }
 \end{code}
 
+
+\begin{code}
+coreBindsSize :: [CoreBind] -> Int
+-- We use coreBindStats for user printout
+-- but this one is a quick and dirty basis for
+-- the simplifier's tick limit
+coreBindsSize bs = foldr ((+) . bindSize) 0 bs
+
+exprSize :: CoreExpr -> Int
+-- ^ A measure of the size of the expressions, strictly greater than 0
+-- It also forces the expression pretty drastically as a side effect
+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.
+exprSize (Var v)         = v `seq` 1
+exprSize (Lit lit)       = lit `seq` 1
+exprSize (App f a)       = exprSize f + exprSize a
+exprSize (Lam b e)       = varSize b + exprSize e
+exprSize (Let b e)       = bindSize b + exprSize e
+exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
+exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e
+exprSize (Tick n e)      = tickSize n + exprSize e
+exprSize (Type t)        = seqType t `seq` 1
+exprSize (Coercion co)   = seqCo co `seq` 1
+
+tickSize :: Tickish Id -> Int
+tickSize (ProfNote cc _ _) = cc `seq` 1
+tickSize _ = 1 -- the rest are strict
+
+varSize :: Var -> Int
+varSize b  | isTyVar b = 1
+           | otherwise = seqType (idType b)             `seq`
+                         megaSeqIdInfo (idInfo b)       `seq`
+                         1
+
+varsSize :: [Var] -> Int
+varsSize = sum . map varSize
+
+bindSize :: CoreBind -> Int
+bindSize (NonRec b e) = varSize b + exprSize e
+bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
+
+pairSize :: (Var, CoreExpr) -> Int
+pairSize (b,e) = varSize b + exprSize e
+
+altSize :: CoreAlt -> Int
+altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
+\end{code}
+
+
 %************************************************************************
 %*                                                                      *
 \subsection{Hashing}
index 812a726..060b63d 100644 (file)
@@ -117,7 +117,7 @@ repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
  = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
             ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
-       ss <- pprTrace "reptop" (ppr bndrs $$ ppr tv_bndrs) $ mkGenSyms bndrs ;
+       ss <- mkGenSyms bndrs ;
 
        -- Bind all the names mainly to avoid repeated use of explicit strings.
        -- Thus we get
index f140c8f..121b269 100644 (file)
@@ -45,7 +45,7 @@ import Var
 import TcRnMonad
 import TcType
 import TcMType
-import TcHsSyn ( mkZonkTcTyVar )
+import TcHsSyn ( zonkTcTypeToType, mkEmptyZonkEnv )
 import TcUnify
 import TcEnv
 
@@ -1131,7 +1131,7 @@ zonkTerm = foldTermM (TermFoldM
 zonkRttiType :: TcType -> TcM Type
 -- Zonk the type, replacing any unbound Meta tyvars
 -- by skolems, safely out of Meta-tyvar-land
-zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta mkTyVarTy)
+zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta)
   where
     zonk_unbound_meta tv 
       = ASSERT( isTcTyVar tv )
index c4c876d..6b7a337 100644 (file)
@@ -181,7 +181,7 @@ pprIfaceTvBndr (tv, IfaceTyConApp tc [])
 pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
 
 pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
-pprIfaceTvBndrs tyvars = hsep (map pprIfaceTvBndr tyvars)
+pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
 \end{code}
 
 ----------------------------- Printing IfaceType ------------------------------------
index e798b7c..aef9a32 100644 (file)
@@ -63,7 +63,7 @@ import Control.Monad
 
 %************************************************************************
 %*                                                                      *
-        loadSrcInterface, loadOrphanModules, loadHomeInterface
+        loadSrcInterface, loadOrphanModules, loadInterfaceForName
 
                 These three are called from TcM-land    
 %*                                                                      *
index 488df37..335df4f 100644 (file)
@@ -1372,7 +1372,8 @@ runPhase LlvmLlc input_fn dflags
                     SysTools.Option "-o", SysTools.FileOption "" output_fn]
                 ++ map SysTools.Option lc_opts
                 ++ [SysTools.Option tbaa]
-                ++ map SysTools.Option fpOpts)
+                ++ map SysTools.Option fpOpts
+                ++ map SysTools.Option abiOpts)
 
     return (next_phase, output_fn)
   where
@@ -1384,12 +1385,19 @@ runPhase LlvmLlc input_fn dflags
         -- while compiling GHC source code. It's probably due to fact that it
         -- does not enable VFP by default. Let's do this manually here
         fpOpts = case platformArch (targetPlatform dflags) of 
-                   ArchARM ARMv7 ext -> if (elem VFPv3 ext)
+                   ArchARM ARMv7 ext -> if (elem VFPv3 ext)
                                       then ["-mattr=+v7,+vfp3"]
                                       else if (elem VFPv3D16 ext)
                                            then ["-mattr=+v7,+vfp3,+d16"]
                                            else []
                    _                 -> []
+        -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still
+        -- compiles into soft-float ABI. We need to explicitly set abi
+        -- to hard
+        abiOpts = case platformArch (targetPlatform dflags) of
+                    ArchARM ARMv7 _ HARD -> ["-float-abi=hard"]
+                    ArchARM ARMv7 _ _    -> []
+                    _                    -> []
 
 -----------------------------------------------------------------------------
 -- LlvmMangle phase
@@ -1538,8 +1546,8 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
 
             elfSectionNote :: String
             elfSectionNote = case platformArch (targetPlatform dflags) of
-                               ArchARM _ _ -> "%note"
-                               _           -> "@note"
+                               ArchARM _ _ -> "%note"
+                               _             -> "@note"
 
 -- The "link info" is a string representing the parameters of the
 -- link.  We save this information in the binary, and the next time we
index c04b474..a497ded 100644 (file)
@@ -357,6 +357,7 @@ data WarningFlag =
    | Opt_WarnUnsafe
    | Opt_WarnSafe
    | Opt_WarnPointlessPragmas
+   | Opt_WarnUnsupportedCallingConventions
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -1842,7 +1843,8 @@ fWarningFlags = [
   ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ),
   ( "warn-unsafe",                      Opt_WarnUnsafe, setWarnUnsafe ),
   ( "warn-safe",                        Opt_WarnSafe, setWarnSafe ),
-  ( "warn-pointless-pragmas",           Opt_WarnPointlessPragmas, nop ) ]
+  ( "warn-pointless-pragmas",           Opt_WarnPointlessPragmas, nop ),
+  ( "warn-unsupported-calling-conventions", Opt_WarnUnsupportedCallingConventions, nop ) ]
 
 -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
 fFlags :: [FlagSpec DynFlag]
@@ -2174,7 +2176,8 @@ standardWarnings
         Opt_WarnDodgyForeignImports,
         Opt_WarnWrongDoBind,
         Opt_WarnAlternativeLayoutRuleTransitional,
-        Opt_WarnPointlessPragmas
+        Opt_WarnPointlessPragmas,
+        Opt_WarnUnsupportedCallingConventions
       ]
 
 minusWOpts :: [WarningFlag]
index 1ad1242..e976e58 100644 (file)
@@ -200,7 +200,7 @@ nativeCodeGen dflags h us cmms
                          ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
                          ,ncgMakeFarBranches        = id
                      }
-                 ArchARM _ _ ->
+                 ArchARM _ _ ->
                      panic "nativeCodeGen: No NCG for ARM"
                  ArchPPC_64 ->
                      panic "nativeCodeGen: No NCG for PPC 64"
index 6067f23..6cd3f00 100644 (file)
@@ -107,13 +107,13 @@ trivColorable
 trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
         | let !cALLOCATABLE_REGS_INTEGER
                   = iUnbox (case platformArch platform of
-                            ArchX86     -> 3
-                            ArchX86_64  -> 5
-                            ArchPPC     -> 16
-                            ArchSPARC   -> 14
-                            ArchPPC_64  -> panic "trivColorable ArchPPC_64"
-                            ArchARM _ _ -> panic "trivColorable ArchARM"
-                            ArchUnknown -> panic "trivColorable ArchUnknown")
+                            ArchX86       -> 3
+                            ArchX86_64    -> 5
+                            ArchPPC       -> 16
+                            ArchSPARC     -> 14
+                            ArchPPC_64    -> panic "trivColorable ArchPPC_64"
+                            ArchARM _ _ -> panic "trivColorable ArchARM"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
         , count2        <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER
                                 (virtualRegSqueeze RcInteger)
                                 conflicts
@@ -127,13 +127,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl
 trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
         | let !cALLOCATABLE_REGS_FLOAT
                   = iUnbox (case platformArch platform of
-                            ArchX86     -> 0
-                            ArchX86_64  -> 0
-                            ArchPPC     -> 0
-                            ArchSPARC   -> 22
-                            ArchPPC_64  -> panic "trivColorable ArchPPC_64"
-                            ArchARM _ _ -> panic "trivColorable ArchARM"
-                            ArchUnknown -> panic "trivColorable ArchUnknown")
+                            ArchX86       -> 0
+                            ArchX86_64    -> 0
+                            ArchPPC       -> 0
+                            ArchSPARC     -> 22
+                            ArchPPC_64    -> panic "trivColorable ArchPPC_64"
+                            ArchARM _ _ -> panic "trivColorable ArchARM"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
         , count2        <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT
                                 (virtualRegSqueeze RcFloat)
                                 conflicts
@@ -147,13 +147,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus
 trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
         | let !cALLOCATABLE_REGS_DOUBLE
                   = iUnbox (case platformArch platform of
-                            ArchX86     -> 6
-                            ArchX86_64  -> 0
-                            ArchPPC     -> 26
-                            ArchSPARC   -> 11
-                            ArchPPC_64  -> panic "trivColorable ArchPPC_64"
-                            ArchARM _ _ -> panic "trivColorable ArchARM"
-                            ArchUnknown -> panic "trivColorable ArchUnknown")
+                            ArchX86       -> 6
+                            ArchX86_64    -> 0
+                            ArchPPC       -> 26
+                            ArchSPARC     -> 11
+                            ArchPPC_64    -> panic "trivColorable ArchPPC_64"
+                            ArchARM _ _ -> panic "trivColorable ArchARM"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
         , count2        <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE
                                 (virtualRegSqueeze RcDouble)
                                 conflicts
@@ -167,13 +167,13 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu
 trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions
         | let !cALLOCATABLE_REGS_SSE
                   = iUnbox (case platformArch platform of
-                            ArchX86     -> 8
-                            ArchX86_64  -> 10
-                            ArchPPC     -> 0
-                            ArchSPARC   -> 0
-                            ArchPPC_64  -> panic "trivColorable ArchPPC_64"
-                            ArchARM _ _ -> panic "trivColorable ArchARM"
-                            ArchUnknown -> panic "trivColorable ArchUnknown")
+                            ArchX86       -> 8
+                            ArchX86_64    -> 10
+                            ArchPPC       -> 0
+                            ArchSPARC     -> 0
+                            ArchPPC_64    -> panic "trivColorable ArchPPC_64"
+                            ArchARM _ _ -> panic "trivColorable ArchARM"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
         , count2        <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE
                                 (virtualRegSqueeze RcDoubleSSE)
                                 conflicts
index 6fbbd04..fd1fd27 100644 (file)
@@ -68,11 +68,11 @@ instance FR SPARC.FreeRegs where
 maxSpillSlots :: Platform -> Int
 maxSpillSlots platform
               = case platformArch platform of
-                ArchX86     -> X86.Instr.maxSpillSlots True  -- 32bit
-                ArchX86_64  -> X86.Instr.maxSpillSlots False -- not 32bit
-                ArchPPC     -> PPC.Instr.maxSpillSlots
-                ArchSPARC   -> SPARC.Instr.maxSpillSlots
-                ArchARM _ _ -> panic "maxSpillSlots ArchARM"
-                ArchPPC_64  -> panic "maxSpillSlots ArchPPC_64"
-                ArchUnknown -> panic "maxSpillSlots ArchUnknown"
+                ArchX86       -> X86.Instr.maxSpillSlots True  -- 32bit
+                ArchX86_64    -> X86.Instr.maxSpillSlots False -- not 32bit
+                ArchPPC       -> PPC.Instr.maxSpillSlots
+                ArchSPARC     -> SPARC.Instr.maxSpillSlots
+                ArchARM _ _ -> panic "maxSpillSlots ArchARM"
+                ArchPPC_64    -> panic "maxSpillSlots ArchPPC_64"
+                ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
 
index fc0bde4..64b0f68 100644 (file)
@@ -180,13 +180,13 @@ linearRegAlloc
 linearRegAlloc dflags first_id block_live sccs
  = let platform = targetPlatform dflags
    in case platformArch platform of
-      ArchX86     -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
-      ArchX86_64  -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
-      ArchSPARC   -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
-      ArchPPC     -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs)   first_id block_live sccs
-      ArchARM _ _ -> panic "linearRegAlloc ArchARM"
-      ArchPPC_64  -> panic "linearRegAlloc ArchPPC_64"
-      ArchUnknown -> panic "linearRegAlloc ArchUnknown"
+      ArchX86       -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
+      ArchX86_64    -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs)   first_id block_live sccs
+      ArchSPARC     -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
+      ArchPPC       -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs)   first_id block_live sccs
+      ArchARM _ _ -> panic "linearRegAlloc ArchARM"
+      ArchPPC_64    -> panic "linearRegAlloc ArchPPC_64"
+      ArchUnknown   -> panic "linearRegAlloc ArchUnknown"
 
 linearRegAlloc'
         :: (FR freeRegs, PlatformOutputable instr, Instruction instr)
index cbc4c17..13293de 100644 (file)
@@ -50,35 +50,35 @@ import qualified SPARC.Regs     as SPARC
 targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt
 targetVirtualRegSqueeze platform
     = case platformArch platform of
-      ArchX86     -> X86.virtualRegSqueeze
-      ArchX86_64  -> X86.virtualRegSqueeze
-      ArchPPC     -> PPC.virtualRegSqueeze
-      ArchSPARC   -> SPARC.virtualRegSqueeze
-      ArchPPC_64  -> panic "targetVirtualRegSqueeze ArchPPC_64"
-      ArchARM _ _ -> panic "targetVirtualRegSqueeze ArchARM"
-      ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown"
+      ArchX86       -> X86.virtualRegSqueeze
+      ArchX86_64    -> X86.virtualRegSqueeze
+      ArchPPC       -> PPC.virtualRegSqueeze
+      ArchSPARC     -> SPARC.virtualRegSqueeze
+      ArchPPC_64    -> panic "targetVirtualRegSqueeze ArchPPC_64"
+      ArchARM _ _ -> panic "targetVirtualRegSqueeze ArchARM"
+      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"
 
 targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt
 targetRealRegSqueeze platform
     = case platformArch platform of
-      ArchX86     -> X86.realRegSqueeze
-      ArchX86_64  -> X86.realRegSqueeze
-      ArchPPC     -> PPC.realRegSqueeze
-      ArchSPARC   -> SPARC.realRegSqueeze
-      ArchPPC_64  -> panic "targetRealRegSqueeze ArchPPC_64"
-      ArchARM _ _ -> panic "targetRealRegSqueeze ArchARM"
-      ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown"
+      ArchX86       -> X86.realRegSqueeze
+      ArchX86_64    -> X86.realRegSqueeze
+      ArchPPC       -> PPC.realRegSqueeze
+      ArchSPARC     -> SPARC.realRegSqueeze
+      ArchPPC_64    -> panic "targetRealRegSqueeze ArchPPC_64"
+      ArchARM _ _ -> panic "targetRealRegSqueeze ArchARM"
+      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"
 
 targetClassOfRealReg :: Platform -> RealReg -> RegClass
 targetClassOfRealReg platform
     = case platformArch platform of
-      ArchX86     -> X86.classOfRealReg
-      ArchX86_64  -> X86.classOfRealReg
-      ArchPPC     -> PPC.classOfRealReg
-      ArchSPARC   -> SPARC.classOfRealReg
-      ArchPPC_64  -> panic "targetClassOfRealReg ArchPPC_64"
-      ArchARM _ _ -> panic "targetClassOfRealReg ArchARM"
-      ArchUnknown -> panic "targetClassOfRealReg ArchUnknown"
+      ArchX86       -> X86.classOfRealReg
+      ArchX86_64    -> X86.classOfRealReg
+      ArchPPC       -> PPC.classOfRealReg
+      ArchSPARC     -> SPARC.classOfRealReg
+      ArchPPC_64    -> panic "targetClassOfRealReg ArchPPC_64"
+      ArchARM _ _ -> panic "targetClassOfRealReg ArchARM"
+      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"
 
 -- TODO: This should look at targetPlatform too
 targetWordSize :: Size
@@ -87,24 +87,24 @@ targetWordSize = intSize wordWidth
 targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg
 targetMkVirtualReg platform
     = case platformArch platform of
-      ArchX86     -> X86.mkVirtualReg
-      ArchX86_64  -> X86.mkVirtualReg
-      ArchPPC     -> PPC.mkVirtualReg
-      ArchSPARC   -> SPARC.mkVirtualReg
-      ArchPPC_64  -> panic "targetMkVirtualReg ArchPPC_64"
-      ArchARM _ _ -> panic "targetMkVirtualReg ArchARM"
-      ArchUnknown -> panic "targetMkVirtualReg ArchUnknown"
+      ArchX86       -> X86.mkVirtualReg
+      ArchX86_64    -> X86.mkVirtualReg
+      ArchPPC       -> PPC.mkVirtualReg
+      ArchSPARC     -> SPARC.mkVirtualReg
+      ArchPPC_64    -> panic "targetMkVirtualReg ArchPPC_64"
+      ArchARM _ _ -> panic "targetMkVirtualReg ArchARM"
+      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"
 
 targetRegDotColor :: Platform -> RealReg -> SDoc
 targetRegDotColor platform
     = case platformArch platform of
-      ArchX86     -> X86.regDotColor platform
-      ArchX86_64  -> X86.regDotColor platform
-      ArchPPC     -> PPC.regDotColor
-      ArchSPARC   -> SPARC.regDotColor
-      ArchPPC_64  -> panic "targetRegDotColor ArchPPC_64"
-      ArchARM _ _ -> panic "targetRegDotColor ArchARM"
-      ArchUnknown -> panic "targetRegDotColor ArchUnknown"
+      ArchX86       -> X86.regDotColor platform
+      ArchX86_64    -> X86.regDotColor platform
+      ArchPPC       -> PPC.regDotColor
+      ArchSPARC     -> SPARC.regDotColor
+      ArchPPC_64    -> panic "targetRegDotColor ArchPPC_64"
+      ArchARM _ _ -> panic "targetRegDotColor ArchARM"
+      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"
 
 
 targetClassOfReg :: Platform -> Reg -> RegClass
index b1ef1d2..97fc0a5 100644 (file)
@@ -1821,6 +1821,12 @@ primop  MkWeakOp "mkWeak#" GenPrimOp
    has_side_effects = True
    out_of_line      = True
 
+primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp
+   o -> b -> State# RealWorld -> (# State# RealWorld, Weak# b #)
+   with
+   has_side_effects = True
+   out_of_line      = True
+
 primop  MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp
    o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #)
    with
index 2834a78..9cb04ff 100644 (file)
@@ -19,7 +19,7 @@ module RnEnv (
         lookupTypeOccRn, lookupKindOccRn, 
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
 
-       HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
+       HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
 
        lookupFixityRn, lookupTyFixityRn, 
        lookupInstDeclBndr, lookupSubBndrOcc, lookupFamInstName,
@@ -238,7 +238,14 @@ lookupExactOcc name
   = return name
   | otherwise           
   = do { env <- getGlobalRdrEnv
-       ; let gres = lookupGRE_Name env name
+       ; let -- See Note [Splicing Exact names] 
+             main_occ =  nameOccName name
+             demoted_occs = case demoteOccName main_occ of
+                              Just occ -> [occ]
+                              Nothing  -> []
+             gres = [ gre | occ <- main_occ : demoted_occs
+                          , gre <- lookupGlobalRdrEnv env occ
+                         , gre_name gre == name ]
        ; case gres of
            []    -> -- See Note [Splicing Exact names]
                     do { lcl_env <- getLocalRdrEnv
@@ -471,6 +478,19 @@ otherwise the type checker will get confused.  To do this we need to
 keep track of all the Names in scope, and the LocalRdrEnv does just that;
 we consult it with RdrName.inLocalRdrEnvScope.
 
+There is another wrinkle.  With TH and -XDataKinds, consider
+   $( [d| data Nat = Zero 
+          data T = MkT (Proxy 'Zero)  |] )
+After splicing, but before renaming we get this:
+   data Nat_77{tc} = Zero_78{d}
+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )
+THe occurrence of 'Zero in the data type for T has the right unique,
+but it has a TcClsName name-space in its OccName.  (This is set by
+the ctxt_ns argument of Convert.thRdrName.)  When we check that is 
+in scope in the GlobalRdrEnv, we need to look up the DataName namespace
+too.  (An alternative would be to make the GlobalRdrEnv also have
+a Name -> GRE mapping.)
+
 Note [Usage for sub-bndrs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 If you have this
@@ -531,18 +551,23 @@ lookupTypeOccRn rdr_name
   = do { mb_name <- lookupOccRn_maybe rdr_name 
        ; case mb_name of {
              Just name -> return name ;
-             Nothing   -> 
-
-    do { -- Maybe it's the name of a *data* constructor
-         data_kinds <- xoptM Opt_DataKinds
-       ; mb_demoted_name <- case demoteRdrName rdr_name of
-                              Just demoted_rdr -> lookupOccRn_maybe demoted_rdr
-                              Nothing          -> return Nothing
+             Nothing   -> lookup_demoted rdr_name } }
+
+lookup_demoted :: RdrName -> RnM Name
+lookup_demoted rdr_name
+  | Just demoted_rdr <- demoteRdrName rdr_name
+    -- Maybe it's the name of a *data* constructor
+  = do { data_kinds <- xoptM Opt_DataKinds
+       ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
        ; case mb_demoted_name of
            Nothing -> unboundName WL_Any rdr_name
            Just demoted_name 
              | data_kinds -> return demoted_name
-             | otherwise  -> unboundNameX WL_Any rdr_name suggest_dk }}}
+             | otherwise  -> unboundNameX WL_Any rdr_name suggest_dk }
+  | otherwise
+  = unboundName WL_Any rdr_name 
+
   where 
     suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?")
 \end{code}
@@ -663,28 +688,111 @@ lookupGreRn_help rdr_name lookup
                         ; return (Just gre) }
            gres  -> do { addNameClashErrRn rdr_name gres
                        ; return (Just (head gres)) } }
+\end{code}
+
+%*********************************************************
+%*                                                     *
+               Deprecations
+%*                                                     *
+%*********************************************************
 
+Note [Handling of deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We report deprecations at each *occurrence* of the deprecated thing
+  (see Trac #5867)
+
+* We do not report deprectations for locally-definded names. For a
+  start, we may be exporting a deprecated thing. Also we may use a
+  deprecated thing in the defn of another deprecated things.  We may
+  even use a deprecated thing in the defn of a non-deprecated thing,
+  when changing a module's interface.
+
+* addUsedRdrNames: we do not report deprecations for sub-binders:
+     - the ".." completion for records
+     - the ".." in an export item 'T(..)'
+     - the things exported by a module export 'module M'
+
+\begin{code}
 addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
 -- Record usage of imported RdrNames
 addUsedRdrName gre rdr
-  | isLocalGRE gre = return ()
+  | isLocalGRE gre = return ()  -- No call to warnIfDeprecated
+                                -- See Note [Handling of deprecations]
   | otherwise      = do { env <- getGblEnv
-                               ; updMutVar (tcg_used_rdrnames env)
+                               ; warnIfDeprecated gre
+                        ; updMutVar (tcg_used_rdrnames env)
                                    (\s -> Set.insert rdr s) }
 
 addUsedRdrNames :: [RdrName] -> RnM ()
 -- Record used sub-binders
 -- We don't check for imported-ness here, because it's inconvenient
 -- and not stritly necessary.
+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
 addUsedRdrNames rdrs
   = do { env <- getGblEnv
        ; updMutVar (tcg_used_rdrnames env)
                   (\s -> foldr Set.insert s rdrs) }
 
-------------------------------
---     GHCi support
-------------------------------
+warnIfDeprecated :: GlobalRdrElt -> RnM ()
+warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _) })
+  = do { dflags <- getDynFlags
+       ; when (wopt Opt_WarnWarningsDeprecations dflags) $
+         do { iface <- loadInterfaceForName doc name
+            ; case lookupImpDeprec iface gre of
+                Just txt -> addWarn (mk_msg txt) 
+                Nothing  -> return () } }
+  where
+    mk_msg txt = sep [ sep [ ptext (sLit "In the use of")
+                             <+> pprNonVarNameSpace (occNameSpace (nameOccName name))
+                             <+> quotes (ppr name)
+                           , parens imp_msg <> colon ]
+                     , ppr txt ]
+
+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    imp_mod  = importSpecModule imp_spec
+    imp_msg  = ptext (sLit "imported from") <+> ppr imp_mod <> extra
+    extra | imp_mod == moduleName name_mod = empty
+          | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
+
+    doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
+
+warnIfDeprecated _ = return ()   -- No deprecations for things defined locally
+
+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
+lookupImpDeprec iface gre
+  = mi_warn_fn iface (gre_name gre) `mplus`  -- Bleat if the thing,
+    case gre_par gre of                      -- or its parent, is warn'd
+       ParentIs p -> mi_warn_fn iface p 
+       NoParent   -> Nothing
+\end{code}
+
+Note [Used names with interface not loaded]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's (just) possible to to find a used
+Name whose interface hasn't been loaded:
+
+a) It might be a WiredInName; in that case we may not load
+   its interface (although we could).
+
+b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
+   These are seen as "used" by the renamer (if -XRebindableSyntax)
+   is on), but the typechecker may discard their uses
+   if in fact the in-scope fromRational is GHC.Read.fromRational,
+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type
+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
+   In that obscure case it won't force the interface in.
+
+In both cases we simply don't permit deprecations;
+this is, after all, wired-in stuff.
 
+
+%*********************************************************
+%*                                                     *
+               GHCi support
+%*                                                     *
+%*********************************************************
+
+\begin{code}
 -- A qualified name on the command line can refer to any module at all: we
 -- try to load the interface if we don't already have it.
 lookupQualifiedName :: RdrName -> RnM (Maybe Name)
@@ -819,30 +927,32 @@ lookupBindGroupOcc ctxt what rdr_name
 
 
 ---------------
-lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
--- GHC extension: look up both the tycon and data con 
--- for con-like things.  Used for top-level fixity signatures
--- Complain if neither is in scope
-lookupLocalDataTcNames bndr_set what rdr_name
+lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
+-- GHC extension: look up both the tycon and data con or variable.
+-- Used for top-level fixity signatures. Complain if neither is in scope.
+-- See Note [Fixity signature lookup]
+lookupLocalTcNames bndr_set what rdr_name
   | Just n <- isExact_maybe rdr_name   
        -- Special case for (:), which doesn't get into the GlobalRdrEnv
   = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too
   | otherwise
-  = do { mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what)
-                         (dataTcOccs rdr_name)
-       ; let (errs, names) = splitEithers mb_gres
-       ; when (null names) (addErr (head errs))        -- Bleat about one only
-       ; return names }
+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
+       ; let (errs, names) = splitEithers mb_gres
+       ; when (null names) $ addErr (head errs) -- Bleat about one only
+       ; return names }
+  where
+    lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what
 
 dataTcOccs :: RdrName -> [RdrName]
--- If the input is a data constructor, return both it and a type
--- constructor.  This is useful when we aren't sure which we are
--- looking at.
+-- Return both the given name and the same name promoted to the TcClsName
+-- namespace.  This is useful when we aren't sure which we are looking at.
 dataTcOccs rdr_name
-  | isDataOcc occ            = [rdr_name, rdr_name_tc]
-  | otherwise                = [rdr_name]
-  where    
-    occ        = rdrNameOcc rdr_name
+  | isDataOcc occ || isVarOcc occ
+  = [rdr_name, rdr_name_tc]
+  | otherwise
+  = [rdr_name]
+  where
+    occ = rdrNameOcc rdr_name
     rdr_name_tc = setRdrNameSpace rdr_name tcName
 \end{code}
 
@@ -853,6 +963,26 @@ dataTcOccs rdr_name
 %*                                                     *
 %*********************************************************
 
+Note [Fixity signature lookup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A fixity declaration like
+
+    infixr 2 ?
+
+can refer to a value-level operator, e.g.:
+
+    (?) :: String -> String -> String
+
+or a type-level operator, like:
+
+    data (?) a b = A a | B b
+
+so we extend the lookup of the reader name '?' to the TcClsName namespace, as
+well as the original namespace.
+
+The extended lookup is also used in other places, like resolution of
+deprecation declarations, and lookup of names in GHCi.
+
 \begin{code}
 --------------------------------
 type FastStringEnv a = UniqFM a                -- Keyed by FastString
index 75f7ea2..69284db 100644 (file)
@@ -8,7 +8,7 @@ module RnNames (
         rnImports, getLocalNonValBinders,
         rnExports, extendGlobalRdrEnvRn,
         gresFromAvails, 
-        reportUnusedNames, finishWarnings,
+        reportUnusedNames, 
     ) where
 
 #include "HsVersions.h"
@@ -904,7 +904,11 @@ rnExports explicit_mod exports
           tcg_env@(TcGblEnv { tcg_mod     = this_mod,
                               tcg_rdr_env = rdr_env,
                               tcg_imports = imports })
- = do   {
+ = unsetWOptM Opt_WarnWarningsDeprecations $
+       -- Do not report deprecations arising from the export
+       -- list, to avoid bleating about re-exporting a deprecated
+       -- thing (especially via 'module Foo' export item)
+   do   {
         -- If the module header is omitted altogether, then behave
         -- as if the user had written "module Main(main) where..."
         -- EXCEPT in interactive mode, when we behave as if he had
@@ -1175,96 +1179,6 @@ dupExport_ok n ie1 ie2
     single _               = False
 \end{code}
 
-%*********************************************************
-%*                                                       *
-\subsection{Deprecations}
-%*                                                       *
-%*********************************************************
-
-\begin{code}
-finishWarnings :: DynFlags -> Maybe WarningTxt
-               -> TcGblEnv -> RnM TcGblEnv
--- (a) Report usage of imports that are deprecated or have other warnings
--- (b) If the whole module is warned about or deprecated, update tcg_warns
---     All this happens only once per module
-finishWarnings dflags mod_warn tcg_env
-  = do  { (eps,hpt) <- getEpsAndHpt
-        ; ifWOptM Opt_WarnWarningsDeprecations $
-          mapM_ (check hpt (eps_PIT eps)) all_gres
-                -- By this time, typechecking is complete,
-                -- so the PIT is fully populated
-
-        -- Deal with a module deprecation; it overrides all existing warns
-        ; let new_warns = case mod_warn of
-                                Just txt -> WarnAll txt
-                                Nothing  -> tcg_warns tcg_env
-        ; return (tcg_env { tcg_warns = new_warns }) }
-  where
-    used_names = allUses (tcg_dus tcg_env)
-        -- Report on all deprecated uses; hence allUses
-    all_gres   = globalRdrEnvElts (tcg_rdr_env tcg_env)
-
-    check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
-      | name `elemNameSet` used_names
-      , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre
-      = addWarnAt (importSpecLoc imp_spec)
-                  (sep [ptext (sLit "In the use of") <+>
-                        pprNonVarNameSpace (occNameSpace (nameOccName name)) <+>
-                        quotes (ppr name),
-                      (parens imp_msg) <> colon,
-                      (ppr deprec_txt) ])
-        where
-          name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-          imp_mod  = importSpecModule imp_spec
-          imp_msg  = ptext (sLit "imported from") <+> ppr imp_mod <> extra
-          extra | imp_mod == moduleName name_mod = empty
-                | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
-
-    check _ _ _ = return ()        -- Local, or not used, or not deprectated
-            -- The Imported pattern-match: don't deprecate locally defined names
-            -- For a start, we may be exporting a deprecated thing
-            -- Also we may use a deprecated thing in the defn of another
-            -- deprecated things.  We may even use a deprecated thing in
-            -- the defn of a non-deprecated thing, when changing a module's
-            -- interface
-
-lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable
-                -> GlobalRdrElt -> Maybe WarningTxt
--- The name is definitely imported, so look in HPT, PIT
-lookupImpDeprec dflags hpt pit gre
-  = case lookupIfaceByModule dflags hpt pit mod of
-        Just iface -> mi_warn_fn iface name `mplus`    -- Bleat if the thing, *or
-                      case gre_par gre of
-                        ParentIs p -> mi_warn_fn iface p    -- its parent*, is warn'd
-                        NoParent   -> Nothing
-
-        Nothing -> Nothing    -- See Note [Used names with interface not loaded]
-  where
-    name = gre_name gre
-    mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-\end{code}
-
-Note [Used names with interface not loaded]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-By now all the interfaces should have been loaded,
-because reportDeprecations happens after typechecking.
-However, it's still (just) possible to to find a used
-Name whose interface hasn't been loaded:
-
-a) It might be a WiredInName; in that case we may not load
-   its interface (although we could).
-
-b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
-   These are seen as "used" by the renamer (if -XRebindableSyntax)
-   is on), but the typechecker may discard their uses
-   if in fact the in-scope fromRational is GHC.Read.fromRational,
-   (see tcPat.tcOverloadedLit), and the typechecker sees that the type
-   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
-   In that obscure case it won't force the interface in.
-
-In both cases we simply don't permit deprecations;
-this is, after all, wired-in stuff.
-
 
 %*********************************************************
 %*                                                       *
index ffd2910..8c338c8 100644 (file)
@@ -269,7 +269,7 @@ rnSrcFixityDecls bndr_set fix_decls
     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
-        do names <- lookupLocalDataTcNames bndr_set what rdr_name
+        do names <- lookupLocalTcNames bndr_set what rdr_name
            return [ L loc (FixitySig (L name_loc name) fixity)
                   | name <- names ]
     what = ptext (sLit "fixity signature")
@@ -304,7 +304,7 @@ rnSrcWarnDecls bndr_set decls
  where
    rn_deprec (Warning rdr_name txt)
        -- ensures that the names are defined locally
-     = do { names <- lookupLocalDataTcNames bndr_set what rdr_name
+     = do { names <- lookupLocalTcNames bndr_set what rdr_name
           ; return [(nameOccName name, txt) | name <- names] }
    
    what = ptext (sLit "deprecation")
index 4af626d..c3a3dce 100644 (file)
@@ -161,14 +161,15 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
   = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc
 
   | otherwise
-  = Err.debugTraceMsg dflags 2 $
-    (sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))])
+  = Err.debugTraceMsg dflags 2 size_doc
           -- Report result size 
          -- This has the side effect of forcing the intermediate to be evaluated
 
   where
+    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
+
     dump_doc  = vcat [ nest 2 extra_info
-                    , nest 2 (text "Result size =" <+> int (coreBindsSize binds))
+                    , size_doc
                      , blankLine
                      , pprCoreBindings binds 
                      , ppUnless (null rules) pp_rules ]
index 0601d7b..c0c6478 100644 (file)
@@ -354,19 +354,27 @@ For @Case@, the possible ``drop points'' for the \tr{to_drop}
 bindings are: (a)~inside the scrutinee, (b)~inside one of the
 alternatives/default [default FVs always {\em first}!].
 
+Floating case expressions inward was added to fix Trac #5658: strict bindings
+not floated in. In particular, this change allows array indexing operations,
+which have a single DEFAULT alternative without any binders, to be floated
+inward. SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
+scalars also need to be floated inward, but unpacks have a single non-DEFAULT
+alternative that binds the elements of the tuple. We now therefore also support
+floating in cases with a single alternative that may bind values.
+
 \begin{code}
-fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
+fiExpr to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
   | isUnLiftedType (idType case_bndr)
   , exprOkForSideEffects (deAnnotate scrut)
   = wrapFloats shared_binds $
     fiExpr (case_float : rhs_binds) rhs
   where
-    case_float = FB (unitVarSet case_bndr) scrut_fvs 
-                    (FloatCase scrut' case_bndr DEFAULT [])
+    case_float = FB (mkVarSet (case_bndr : alt_bndrs)) scrut_fvs 
+                    (FloatCase scrut' case_bndr con alt_bndrs)
     scrut' = fiExpr scrut_binds scrut
     [shared_binds, scrut_binds, rhs_binds]
        = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop
-    rhs_fvs   = freeVarsOf rhs `delVarSet` case_bndr
+    rhs_fvs   = freeVarsOf rhs `delVarSetList` (case_bndr : alt_bndrs)
     scrut_fvs = freeVarsOf scrut
 
 fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
index 03ffb47..daadcb7 100644 (file)
@@ -25,7 +25,7 @@ import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
 import PprCore          ( pprCoreBindings, pprCoreExpr )
 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
 import IdInfo
-import CoreUtils        ( coreBindsSize, exprSize )
+import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize )
 import Simplify         ( simplTopBinds, simplExpr )
 import SimplUtils       ( simplEnvForGHCi, activeRule )
 import SimplEnv
@@ -585,7 +585,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
               <+> ptext (sLit "iterations")
               <+> (brackets $ hsep $ punctuate comma $
                    map (int . simplCountN) (reverse counts_so_far))
-              <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
+              <+> ptext (sLit "Size =") <+> ppr (coreBindsStats binds) )
 
                 -- Subtract 1 from iteration_no to get the
                 -- number of iterations we actually completed
index e025e6c..3b18540 100644 (file)
@@ -65,7 +65,8 @@ data SimplTopEnv
 \begin{code}
 initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv) 
         -> UniqSupply          -- No init count; set to 0
-        -> Int                 -- Size of the bindings
+        -> Int                 -- Size of the bindings, used to limit
+                                -- the number of ticks we allow
         -> SimplM a
         -> (a, SimplCount)
 
index 0af0b7f..7bb4289 100644 (file)
@@ -1171,9 +1171,11 @@ findArity dflags bndr rhs old_arity
       | cur_arity <= old_arity = cur_arity     
       | new_arity == cur_arity = cur_arity
       | otherwise = ASSERT( new_arity < cur_arity )
+#ifdef DEBUG
                     pprTrace "Exciting arity" 
                        (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity
                              , ppr rhs])
+#endif
                     go new_arity
       where
         new_arity = exprEtaExpandArity dflags cheap_app rhs
index 9662fae..c43450c 100644 (file)
@@ -254,14 +254,15 @@ addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamIns
 addLocalFamInst (home_fie, my_fis) fam_inst 
         -- home_fie includes home package and this module
         -- my_fies is just the ones from this module
-  = do { isGHCi <- getIsGHCi
+  = do { traceTc "addLocalFamInst" (ppr fam_inst)
+       ; isGHCi <- getIsGHCi
  
            -- In GHCi, we *override* any identical instances
            -- that are also defined in the interactive context
-      ; let (home_fie', my_fis') 
-              | isGHCi    = (deleteFromFamInstEnv home_fie fam_inst, 
-                             filterOut (identicalFamInst fam_inst) my_fis)
-              | otherwise = (home_fie, my_fis)
+       ; let (home_fie', my_fis') 
+               | isGHCi    = ( deleteFromFamInstEnv home_fie fam_inst 
+                             filterOut (identicalFamInst fam_inst) my_fis)
+               | otherwise = (home_fie, my_fis)
 
            -- Load imported instances, so that we report
            -- overlaps correctly
index 1967976..2e870da 100644 (file)
@@ -7,7 +7,7 @@ module TcEnv(
         TyThing(..), TcTyThing(..), TcId,
 
         -- Instance environment, and InstInfo type
-        InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
+        InstInfo(..), iDFunId, pprInstInfoDetails,
         simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, 
         InstBindings(..),
 
@@ -669,17 +669,10 @@ data InstBindings a
                         -- See Note [Newtype deriving and unused constructors]
                         -- in TcDeriv
 
-pprInstInfo :: InstInfo a -> SDoc
-pprInstInfo info = hang (ptext (sLit "instance"))
-                      2 (sep [ ifPprDebug (pprForAll tvs)
-                             , pprThetaArrowTy theta, ppr tau
-                             , ptext (sLit "where")])
-  where
-    (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
-
-
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
-pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
+pprInstInfoDetails info 
+   = hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where"))
+        2 (details (iBinds info))
   where
     details (VanillaInst b _ _) = pprLHsBinds b
     details (NewTypeDerived {}) = text "Derived from the representation type"
index 0fcd0d4..63a5bee 100644 (file)
@@ -85,7 +85,8 @@ reportUnsolved runtimeCoercionErrors wanted
                             , cec_tidy  = tidy_env
                             , cec_defer = defer }
 
-       ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted)
+       ; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs)
+                                         , ppr wanted ])
 
        ; reportWanteds err_ctxt wanted
 
index ae8ac26..34632a5 100644 (file)
@@ -48,6 +48,8 @@ import Platform
 import SrcLoc
 import Bag
 import FastString
+
+import Control.Monad
 \end{code}
 
 \begin{code}
@@ -454,7 +456,8 @@ checkCConv StdCallConv  = do dflags <- getDynFlags
                              if platformArch platform == ArchX86
                                  then return StdCallConv
                                  else do -- This is a warning, not an error. see #3336
-                                         addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
+                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
+                                             addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
                                          return CCallConv
 checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
                              return PrimCallConv
index 9493669..c4a2c33 100644 (file)
@@ -263,18 +263,20 @@ tc_mkRepTyCon tycon metaDts mod =
   do { -- `rep0` = GHC.Generics.Rep (type family)
        rep0 <- tcLookupTyCon repTyConName
 
+     ; let -- `tyvars` = [a,b]
+           tyvars     = tyConTyVars tycon
+           tyvar_args = mkTyVarTys tyvars
+
+           -- `appT` = D a b
+           appT = [mkTyConApp tycon tyvar_args]
+
        -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; rep0Ty <- tc_mkRepTy tycon metaDts
+     ; rep0Ty <- tc_mkRepTy tycon tyvar_args metaDts
     
        -- `rep_name` is a name we generate for the synonym
      ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon)))
                      (nameSrcSpan (tyConName tycon))
 
-     ; let -- `tyvars` = [a,b]
-           tyvars  = tyConTyVars tycon
-
-           -- `appT` = D a b
-           appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
      ; return $ mkSynFamInst rep_name tyvars rep0 appT rep0Ty
      }
 
@@ -284,13 +286,13 @@ tc_mkRepTyCon tycon metaDts mod =
 -- Type representation
 --------------------------------------------------------------------------------
 
-tc_mkRepTy :: -- The type to generate representation for
-               TyCon 
+tc_mkRepTy :: -- The type to generate representation for, and instantiating types
+               TyCon -> [Type]    
                -- Metadata datatypes to refer to
             -> MetaTyCons 
                -- Generated representation0 type
             -> TcM Type
-tc_mkRepTy tycon metaDts = 
+tc_mkRepTy tycon ty_args metaDts = 
   do
     d1    <- tcLookupTyCon d1TyConName
     c1    <- tcLookupTyCon c1TyConName
@@ -308,7 +310,7 @@ tc_mkRepTy tycon metaDts =
         mkRec0 a   = mkTyConApp rec0  [a]
         mkPar0 a   = mkTyConApp par0  [a]
         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
-        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConInstOrigArgTys a ty_args
                                                  (null (dataConFieldLabels a))]
         -- This field has no label
         mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
index 75dedd0..a4af0ce 100644 (file)
@@ -26,9 +26,10 @@ module TcHsSyn (
        -- re-exported from TcMonad
        TcId, TcIdSet, 
 
-       zonkTopDecls, zonkTopExpr, zonkTopLExpr, mkZonkTcTyVar,
-       zonkId, zonkTopBndrs,
-        emptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes
+       zonkTopDecls, zonkTopExpr, zonkTopLExpr, 
+       zonkTopBndrs, zonkTyBndrsX,
+        emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, 
+        zonkTcTypeToType, zonkTcTypeToTypes
   ) where
 
 #include "HsVersions.h"
@@ -37,8 +38,9 @@ import HsSyn
 import Id
 import TcRnMonad
 import PrelNames
+import TypeRep     -- We can see the representation of types
 import TcType
-import TcMType
+import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
 import TcEvidence
 import TysPrim
 import TysWiredIn
@@ -161,14 +163,6 @@ hsOverLitName (HsIsString {})   = fromStringName
 %*                                                                     *
 %************************************************************************
 
-\begin{code}
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> TcM TcId
-zonkId id
-  = zonkTcType (idType id) `thenM` \ ty' ->
-    returnM (Id.setIdType id ty')
-\end{code}
-
 The rest of the zonking is done *after* typechecking.
 The main zonking pass runs over the bindings
 
@@ -195,7 +189,7 @@ data ZonkEnv
   = ZonkEnv 
       UnboundTyVarZonker
       (TyVarEnv TyVar)          -- 
-      (IdEnv Var)              -- What variables are in scope
+      (IdEnv    Var)           -- What variables are in scope
        -- Maps an Id or EvVar to its zonked version; both have the same Name
        -- Note that all evidence (coercion variables as well as dictionaries)
        --      are kept in the ZonkEnv
@@ -207,7 +201,10 @@ instance Outputable ZonkEnv where
 
 
 emptyZonkEnv :: ZonkEnv
-emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv
+emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping
+
+mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
+mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
 
 extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
 extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids 
@@ -1041,7 +1038,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 
        ; let final_bndrs :: [RuleBndr Var]
              final_bndrs = map (RuleBndr . noLoc)
-                             (varSetElemsKvsFirst unbound_tkvs)
+                               (varSetElemsKvsFirst unbound_tkvs)
                            ++ new_bndrs
 
        ; return $ 
@@ -1249,37 +1246,58 @@ DV, TODO: followup on this note mentioning new examples I will add to perf/
 
 
 \begin{code}
-mkZonkTcTyVar :: (TcTyVar -> TcM Type) -- What to do for an *mutable Flexi* var
-             -> (TcTyVar -> Type)      -- What to do for an immutable var
-             -> TcTyVar -> TcM TcType
-mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn
-  = zonk_tv
-  where
-    zonk_tv tv 
-     = ASSERT( isTcTyVar tv )
-       case tcTyVarDetails tv of
-         SkolemTv {}    -> return (unbound_ivar_fn tv)
-         RuntimeUnk {}  -> return (unbound_ivar_fn tv)
-         FlatSkol ty    -> zonkType zonk_tv ty
+zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
+zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
+  | isTcTyVar tv
+  = case tcTyVarDetails tv of
+         SkolemTv {}    -> lookup_in_env
+         RuntimeUnk {}  -> lookup_in_env
+         FlatSkol ty    -> zonkTcTypeToType env ty
          MetaTv _ ref   -> do { cts <- readMutVar ref
                              ; case cts of    
                                   Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
-                                                         zonkType zonk_tv (tyVarKind tv)
-                                               ; unbound_mvar_fn (setTyVarKind tv kind) }
-                                  Indirect ty -> do { zty <- zonkType zonk_tv ty 
+                                                         zonkTcTypeToType env (tyVarKind tv)
+                                               ; zonk_unbound_tyvar (setTyVarKind tv kind) }
+                                  Indirect ty -> do { zty <- zonkTcTypeToType env ty 
                                                      -- Small optimisation: shortern-out indirect steps
                                                      -- so that the old type may be more easily collected.
                                                      ; writeMutVar ref (Indirect zty)
                                                      ; return zty } }
+  | otherwise
+  = lookup_in_env
+  where
+    lookup_in_env    -- Look up in the env just as we do for Ids
+      = case lookupVarEnv tv_env tv of
+          Nothing  -> return (mkTyVarTy tv)
+          Just tv' -> return (mkTyVarTy tv')
 
 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
-zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
-  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar zonk_bound_tyvar)
+zonkTcTypeToType env ty
+  = go ty
   where
-    zonk_bound_tyvar tv    -- Look up in the env just as we do for Ids
-      = case lookupVarEnv tv_env tv of
-          Nothing  -> mkTyVarTy tv
-          Just tv' -> mkTyVarTy tv'
+    go (TyConApp tc tys) = do tys' <- mapM go tys
+                              return (TyConApp tc tys')
+
+    go (LitTy n)         = return (LitTy n)
+
+    go (FunTy arg res)   = do arg' <- go arg
+                              res' <- go res
+                              return (FunTy arg' res')
+
+    go (AppTy fun arg)   = do fun' <- go fun
+                              arg' <- go arg
+                              return (mkAppTy fun' arg')
+               -- NB the mkAppTy; we might have instantiated a
+               -- type variable to a type constructor, so we need
+               -- to pull the TyConApp to the top.
+
+       -- The two interesting cases!
+    go (TyVarTy tv) = zonkTyVarOcc env tv
+
+    go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do
+                          do { (env', tv') <- zonkTyBndrX env tv
+                             ; ty' <- zonkTcTypeToType env' ty
+                             ; return (ForAllTy tv' ty') }
 
 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
index 3ba9fbb..24cd442 100644 (file)
@@ -24,7 +24,7 @@ module TcHsType (
 
                -- Kind-checking types
                 -- No kind generalisation, no checkValidType
-       tcHsTyVarBndrs, tcHsTyVarBndrsGen ,
+       tcHsTyVarBndrs, 
         tcHsLiftedType, 
        tcLHsType, tcCheckLHsType, 
         tcHsContext, tcInferApps, tcHsArgTys,
@@ -177,8 +177,8 @@ tcHsSigTypeNC ctxt (L loc hs_ty)
           -- The kind is checked by checkValidType, and isn't necessarily
           -- of kind * in a Template Haskell quote eg [t| Maybe |]
 
+          -- Generalise here: see Note [ generalisation]
         ; ty <- tcCheckHsTypeAndGen hs_ty kind
-                -- Generalise here: see Note [Kind generalisation]
 
           -- Zonk to expose kind information to checkValidType
         ; ty <- zonkTcType ty
@@ -826,36 +826,18 @@ tcHsTyVarBndr (L _ hs_tv)
        { kind <- case hs_tv of
                    UserTyVar {} -> newMetaKindVar
                    KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
-       ; return (mkTyVar name kind) } } }
+       ; return (mkTcTyVar name kind (SkolemTv False)) } } }
 
 ------------------
-tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] 
-                 -> TcM (TcTyVarSet, r)  -- Result + free tyvars of thing inside
-                 -> TcM ([TyVar], r)     -- Generalised kind variables 
-                                          -- + zonked tyvars + result result
--- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside
--- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)]
-tcHsTyVarBndrsGen hs_tvs thing_inside
-  = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) 
-       ; (tvs, (ftvs, res)) <- tcHsTyVarBndrs hs_tvs $ \ tvs ->
-                       do { res <- thing_inside
-                          ; return (tvs, res) }
-       ; let kinds = map tyVarKind tvs
-       ; kvs' <- kindGeneralize (tyVarsOfTypes kinds `unionVarSet` 
-                                        (ftvs `delVarSetList` tvs))
-       ; zonked_kinds <- mapM zonkTcKind kinds
-       ; let tvs' = zipWith setTyVarKind tvs zonked_kinds
-                     -- See Note [Kinds of quantified type variables]
-       ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs))
-       ; return (kvs' ++ tvs', res) }
-
--------------------
 kindGeneralize :: TyVarSet -> TcM [KindVar]
 kindGeneralize tkvs
   = do { gbl_tvs  <- tcGetGlobalTyVars -- Already zonked
        ; tidy_env <- tcInitTidyEnv
        ; tkvs     <- zonkTyVarsAndFV tkvs
        ; let kvs_to_quantify = varSetElems (tkvs `minusVarSet` gbl_tvs)
+                -- Any type varaibles in tkvs will be in scope,
+                -- and hence in gbl_tvs, so after removing gbl_tvs
+                -- we should only have kind variables left
 
              (_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify
                            -- We do not get a later chance to tidy!
@@ -1317,8 +1299,8 @@ tc_lhs_kind (L span ki) = setSrcSpan span (tc_hs_kind ki)
 
 -- The main worker
 tc_hs_kind :: HsKind Name -> TcM Kind
-tc_hs_kind k@(HsTyVar _)   = tc_app k []
-tc_hs_kind k@(HsAppTy _ _) = tc_app k []
+tc_hs_kind k@(HsTyVar _)   = tc_kind_app k []
+tc_hs_kind k@(HsAppTy _ _) = tc_kind_app k []
 
 tc_hs_kind (HsParTy ki) = tc_lhs_kind ki
 
@@ -1343,18 +1325,17 @@ tc_hs_kind (HsTupleTy _ kis) =
 tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k)
 
 -- Special case for kind application
-tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
-tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis)
-tc_app (HsTyVar tc)      kis =
-  do arg_kis <- mapM tc_lhs_kind kis
-     tc_var_app tc arg_kis
-tc_app ki                _   = failWithTc (quotes (ppr ki) <+> 
+tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
+tc_kind_app (HsAppTy ki1 ki2) kis = tc_kind_app (unLoc ki1) (ki2:kis)
+tc_kind_app (HsTyVar tc)      kis = do { arg_kis <- mapM tc_lhs_kind kis
+                                       ; tc_kind_var_app tc arg_kis }
+tc_kind_app ki                _   = failWithTc (quotes (ppr ki) <+> 
                                     ptext (sLit "is not a kind constructor"))
 
-tc_var_app :: Name -> [Kind] -> TcM Kind
+tc_kind_var_app :: Name -> [Kind] -> TcM Kind
 -- Special case for * and Constraint kinds
 -- They are kinds already, so we don't need to promote them
-tc_var_app name arg_kis
+tc_kind_var_app name arg_kis
   |  name == liftedTypeKindTyConName
   || name == constraintKindTyConName
   = do { unless (null arg_kis)
@@ -1362,39 +1343,48 @@ tc_var_app name arg_kis
        ; thing <- tcLookup name
        ; case thing of
            AGlobal (ATyCon tc) -> return (mkTyConApp tc [])
-           _                   -> panic "tc_var_app 1" }
+           _                   -> panic "tc_kind_var_app 1" }
 
 -- General case
-tc_var_app name arg_kis = do
-  (_errs, mb_thing) <- tryTc (tcLookup name)
-  case mb_thing of
-    Just (AGlobal (ATyCon tc))
-      | isAlgTyCon tc || isTupleTyCon tc -> do
-      data_kinds <- xoptM Opt_DataKinds
-      unless data_kinds $ addErr (dataKindsErr name)
-      case isPromotableTyCon tc of
-        Just n | n == length arg_kis ->
-          return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
-        Just _  -> err tc "is not fully applied"
-        Nothing -> err tc "is not promotable"
-
-    -- A lexically scoped kind variable
-    Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
-
-    -- It is in scope, but not what we expected
-    Just thing -> wrongThingErr "promoted type" thing name
-
-    -- It is not in scope, but it passed the renamer: staging error
-    Nothing    -> -- ASSERT2 ( isTyConName name, ppr name )
-              do  env <- getLclEnv
-                  traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
-                  failWithTc (ptext (sLit "Promoted kind") <+> 
-                              quotes (ppr name) <+>
-                              ptext (sLit "used in a mutually recursive group"))
+tc_kind_var_app name arg_kis
+  = do { (_errs, mb_thing) <- tryTc (tcLookup name)
+       ;  case mb_thing of
+          Just (AGlobal (ATyCon tc))
+            | isAlgTyCon tc || isTupleTyCon tc
+            -> do { data_kinds <- xoptM Opt_DataKinds
+                  ; unless data_kinds $ addErr (dataKindsErr name)
+                  ; case isPromotableTyCon tc of
+                      Just n | n == length arg_kis ->
+                        return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
+                      Just _  -> err tc "is not fully applied"
+                      Nothing -> err tc "is not promotable" }
+
+          -- A lexically scoped kind variable
+          Just (ATyVar _ kind_var) 
+             | not (isKindVar kind_var) 
+             -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr kind_var)
+                            <+> ptext (sLit "used as a kind"))
+             | not (null arg_kis) -- Kind variables always have kind BOX, 
+                                  -- so cannot be applied to anything
+             -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name)
+                            <+> ptext (sLit "cannot appear in a function position"))
+             | otherwise 
+             -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
+
+          -- It is in scope, but not what we expected
+          Just thing -> wrongThingErr "promoted type" thing name
+
+          -- It is not in scope, but it passed the renamer: staging error
+          Nothing    
+             -> -- ASSERT2 ( isTyConName name, ppr name )
+               do { env <- getLclEnv
+                  ; traceTc "tc_kind_var_app" (ppr name $$ ppr (tcl_env env))
+                  ; failWithTc (ptext (sLit "Promoted kind") <+> 
+                                 quotes (ppr name) <+>
+                                 ptext (sLit "used in a mutually recursive group")) } }
   where 
    err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind")
                         <+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg))
-
 \end{code}
 
 %************************************************************************
index 6db2692..7766890 100644 (file)
@@ -386,8 +386,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                         -- more errors still
 
        ; traceTc "tcDeriving" empty
+       ; th_stage <- getStage   -- See Note [Deriving inside TH brackets ]
        ; (gbl_env, deriv_inst_info, deriv_binds)
-              <- tcDeriving tycl_decls inst_decls deriv_decls
+              <- if isBrackStage th_stage 
+                 then return (gbl_env, emptyBag, emptyValBindsOut)
+                 else tcDeriving tycl_decls inst_decls deriv_decls
+
 
        -- Check that if the module is compiled with -XSafe, there are no
        -- hand written instances of Typeable as then unsafe casts could be
@@ -443,6 +447,23 @@ addFamInsts fam_insts thing_inside
     things = map ATyCon tycons ++ map ACoAxiom axioms 
 \end{code}
 
+Note [Deriving inside TH brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a declaration bracket
+  [d| data T = A | B deriving( Show ) |]
+
+there is really no point in generating the derived code for deriving(
+Show) and then type-checking it. This will happen at the call site
+anyway, and the type check should never fail!  Moreover (Trac #6005)
+the scoping of the generated code inside the bracket does not seem to 
+work out.  
+
+The easy solution is simply not to generate the derived instances at
+all.  (A less brutal solution would be to generate them with no
+bindings.)  This will become moot when we shift to the new TH plan, so 
+the brutal solution will do.
+
+
 Note [Instance declaration cycles]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With -XDataKinds we can get this
index dde7021..c62c778 100644 (file)
@@ -1463,6 +1463,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc dict_id)
        ; let fd_eqns = improveFromInstEnv instEnvs 
                             (mkClassPred cls xis, pprArisingAt loc)
 
+       ; traceTcS "improve" (vcat [ppr cls <+> ppr xis, vcat (map pprEquation fd_eqns), ppr (snd instEnvs)])
        ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc
        ; case any_fundeps of
            -- No Functional Dependencies
index d4d4952..3ba80e3 100644 (file)
@@ -59,16 +59,15 @@ module TcMType (
 
   --------------------------------
   -- Zonking
-  zonkType, zonkKind, zonkTcPredType, 
+  zonkTcPredType, 
   skolemiseSigTv, skolemiseUnboundMetaTyVar,
   zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, 
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
 
   zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts,
-  zonkImplication, zonkEvVar, zonkWC, 
+  zonkImplication, zonkEvVar, zonkWC, zonkId,
 
-  zonkTcTypeAndSubst,
   tcGetGlobalTyVars, 
   ) where
 
@@ -491,50 +490,10 @@ zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
 zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
 
 -----------------  Types
-zonkTcType :: TcType -> TcM TcType
--- Simply look through all Flexis
-zonkTcType ty = zonkType zonkTcTyVar ty
-
-zonkTcTyVar :: TcTyVar -> TcM TcType
--- Simply look through all Flexis
-zonkTcTyVar tv
-  = ASSERT2( isTcTyVar tv, ppr tv ) do
-    case tcTyVarDetails tv of
-      SkolemTv {}   -> zonk_kind_and_return
-      RuntimeUnk {} -> zonk_kind_and_return
-      FlatSkol ty   -> zonkTcType ty
-      MetaTv _ ref  -> do { cts <- readMutVar ref
-                          ; case cts of
-                              Flexi       -> zonk_kind_and_return
-                              Indirect ty -> zonkTcType ty }
-  where
-    zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
-                              ; return (TyVarTy z_tv) }
-
 zonkTyVarKind :: TyVar -> TcM TyVar
 zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv)
                       ; return (setTyVarKind tv kind') }
 
-zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType
--- Zonk, and simultaneously apply a non-necessarily-idempotent substitution
-zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
-  where
-    zonk_tv tv
-      = do { z_tv <- updateTyVarKindM zonkTcKind tv
-           ; ASSERT ( isTcTyVar tv )
-             case tcTyVarDetails tv of
-                SkolemTv {}   -> return (TyVarTy z_tv)
-                RuntimeUnk {} -> return (TyVarTy z_tv)
-                FlatSkol ty   -> zonkType zonk_tv ty
-                MetaTv _ ref  -> do { cts <- readMutVar ref
-                                    ; case cts of
-                                  Flexi       -> zonk_flexi z_tv
-                                  Indirect ty -> zonkType zonk_tv ty } }
-    zonk_flexi tv
-      = case lookupTyVar subst tv of
-          Just ty -> zonkType zonk_tv ty
-          Nothing -> return (TyVarTy tv)
-
 zonkTcTypes :: [TcType] -> TcM [TcType]
 zonkTcTypes tys = mapM zonkTcType tys
 
@@ -777,23 +736,25 @@ simplifier knows how to deal with.
 
 %************************************************************************
 %*                                                                     *
-\subsection{Zonking -- the main work-horses: zonkType, zonkTyVar}
+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}
 %*                                                                     *
 %*             For internal use only!                                  *
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+  = do { ty' <- zonkTcType (idType id)
+       ; return (Id.setIdType id ty') }
+
 -- For unbound, mutable tyvars, zonkType uses the function given to it
 -- For tyvars bound at a for-all, zonkType zonks them to an immutable
 --     type variable and zonks the kind too
 
-zonkKind :: (TcTyVar -> TcM Kind) -> TcKind -> TcM Kind
-zonkKind = zonkType
-
-zonkType :: (TcTyVar -> TcM Type)  -- What to do with TcTyVars
-         -> TcType -> TcM Type
-zonkType zonk_tc_tyvar ty
+zonkTcType :: TcType -> TcM TcType
+zonkTcType ty
   = go ty
   where
     go (TyConApp tc tys) = do tys' <- mapM go tys
@@ -813,7 +774,7 @@ zonkType zonk_tc_tyvar ty
                -- to pull the TyConApp to the top.
 
        -- The two interesting cases!
-    go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
+    go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar
                       | otherwise       = TyVarTy <$> updateTyVarKindM go tyvar
                -- Ordinary (non Tc) tyvars occur inside quantified types
 
@@ -821,6 +782,22 @@ zonkType zonk_tc_tyvar ty
                              ty' <- go ty
                              tyvar' <- updateTyVarKindM go tyvar
                              return (ForAllTy tyvar' ty')
+
+zonkTcTyVar :: TcTyVar -> TcM TcType
+-- Simply look through all Flexis
+zonkTcTyVar tv
+  = ASSERT2( isTcTyVar tv, ppr tv ) do
+    case tcTyVarDetails tv of
+      SkolemTv {}   -> zonk_kind_and_return
+      RuntimeUnk {} -> zonk_kind_and_return
+      FlatSkol ty   -> zonkTcType ty
+      MetaTv _ ref  -> do { cts <- readMutVar ref
+                          ; case cts of
+                              Flexi       -> zonk_kind_and_return
+                              Indirect ty -> zonkTcType ty }
+  where
+    zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
+                              ; return (TyVarTy z_tv) }
 \end{code}
 
 
index 7b759d1..38ef6bc 100644 (file)
@@ -154,7 +154,8 @@ data TcSigInfo
 
 instance Outputable TcSigInfo where
     ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
-        = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
+        = ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
+                                     , ppr (map fst tyvars) ]
 \end{code}
 
 Note [Kind vars in sig_tvs]
index 2e33e1f..80c792f 100644 (file)
@@ -152,7 +152,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 
         tcg_env <- {-# SCC "tcRnImports" #-}
                    tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
-        setGblEnv tcg_env               $ do {
+
+          -- If the whole module is warned about or deprecated 
+          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
+          -- a WarnAll, it will override any subseqent depracations added to tcg_warns
+        let { tcg_env1 = case mod_deprec of 
+                         Just txt -> tcg_env { tcg_warns = WarnAll txt } 
+                         Nothing  -> tcg_env 
+            } ;
+        setGblEnv tcg_env1 $ do {
 
                 -- Load the hi-boot interface for this module, if any
                 -- We do this now so that the boot_names can be passed
@@ -173,16 +182,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                         tcRnSrcDecls boot_iface local_decls ;
         setGblEnv tcg_env               $ do {
 
-                -- Report the use of any deprecated things
-                -- We do this *before* processsing the export list so
-                -- that we don't bleat about re-exporting a deprecated
-                -- thing (especially via 'module Foo' export item)
-                -- That is, only uses in the *body* of the module are complained about
-        traceRn (text "rn3") ;
-        failIfErrsM ;   -- finishWarnings crashes sometimes
-                        -- as a result of typechecker repairs (e.g. unboundNames)
-        tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
-
                 -- Process the export list
         traceRn (text "rn4a: before exports");
         tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
@@ -1796,7 +1795,7 @@ pprModGuts (ModGuts { mg_tcs = tcs
 
 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
 ppr_types insts type_env
-  = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
+  = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
   where
     dfun_ids = map instanceDFunId insts
     ids = [id | id <- typeEnvIds type_env, want_sig id]
@@ -1838,7 +1837,7 @@ ppr_sigs ids
   = vcat (map ppr_sig (sortLe le_sig ids))
   where
     le_sig id1 id2 = getOccName id1 <= getOccName id2
-    ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
+    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
 
 ppr_tydecls :: [TyCon] -> SDoc
 ppr_tydecls tycons
index 4a5bd49..ca7cf88 100644 (file)
@@ -1494,7 +1494,8 @@ matchClass clas tys
             ([], unifs, _)               -- Nothing matches  
                 -> do { traceTcS "matchClass not matching"
                                  (vcat [ text "dict" <+> ppr pred, 
-                                         text "unifs" <+> ppr unifs ]) 
+                                         text "unifs" <+> ppr unifs,
+                                         ppr instEnvs ]) 
                       ; return MatchInstNo  
                       } ;  
            ([(ispec, inst_tys)], [], _) -- A single match 
index 6807fc8..b880294 100644 (file)
@@ -269,31 +269,30 @@ kcTyClGroup decls
          -- Step 1: Bind kind variables for non-synonyms
         ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
        ; initial_kinds <- concatMapM getInitialKinds non_syn_decls
-       ; tcExtendTcTyThingEnv initial_kinds $  do
 
-          -- Step 2: kind-check the synonyms, and extend envt
-        { tcl_env <- kcSynDecls (calcSynCycles syn_decls)
-        ; setLclEnv tcl_env $  do
-
-          -- Step 3: kind-check the synonyms
-        { mapM_ kcLTyClDecl non_syn_decls
+       ; tcl_env <- tcExtendTcTyThingEnv initial_kinds $  do
+                     do { -- Step 2: kind-check the synonyms, and extend envt
+                          tcl_env <- kcSynDecls (calcSynCycles syn_decls)
+                            -- Step 3: kind-check the synonyms
+                        ; setLclEnv tcl_env $
+                          do { mapM_ kcLTyClDecl non_syn_decls
+                             ; getLclTypeEnv } }
 
             -- Step 4: generalisation
             -- Kind checking done for this group
              -- Now we have to kind generalize the flexis
-        ; res <- mapM generalise (tyClsBinders decls) 
+        ; res <- mapM (generalise tcl_env) (tyClsBinders decls) 
 
         ; traceTc "kcTyClGroup result" (ppr res)
-        ; return res }}}
+        ; return res }
 
   where
-    generalise :: Name -> TcM (Name, Kind)
-    generalise name
+    generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
+    generalise kind_env name
       = do { traceTc "Generalise type of" (ppr name)
-           ; thing <- tcLookup name
-           ; let kc_kind = case thing of
-                               AThing k -> k
-                               _ -> pprPanic "kcTyClGroup" (ppr thing)
+           ; let kc_kind = case lookupNameEnv kind_env name of
+                               Just (AThing k) -> k
+                               _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
            ; kvs <- kindGeneralize (tyVarsOfType kc_kind)
            ; kc_kind' <- zonkTcKind kc_kind
            ; return (name, mkForAllTys kvs kc_kind') }
@@ -342,7 +341,7 @@ getInitialKinds (L _ decl)
     get_tvs (ForeignType {})                = []
  
 ----------------
-kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM (TcLclEnv) -- Kind bindings
+kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv   -- Kind bindings
 kcSynDecls [] = getLclEnv
 kcSynDecls (group : groups)
   = do { nk <- kcSynDecl1 group
@@ -408,9 +407,15 @@ kcTyClDecl (TyFamily { tcdLName = L _ name, tcdTyVars = hs_tvs
 kcTyDefn :: HsTyDefn Name -> Kind -> TcM ()
 kcTyDefn (TyData { td_ND = new_or_data, td_ctxt = ctxt
                  , td_cons = cons, td_kindSig = mb_kind }) res_k
-  = do { _ <- tcHsContext ctxt
+  = do { traceTc "kcTyDefn1" (ppr cons)
+        ; _ <- tcHsContext ctxt
+--     ; let h98_syntax = consUseH98Syntax cons
+--      ; when h98_syntax $ mapM_ (wrapLocM (kcConDecl new_or_data)) cons 
        ; mapM_ (wrapLocM (kcConDecl new_or_data)) cons 
-        ; kcResultKind mb_kind res_k }
+        ; traceTc "kcTyDefn2" (ppr cons)
+        ; kcResultKind mb_kind res_k
+        ; traceTc "kcTyDefn3" (ppr cons)
+        }
 kcTyDefn (TySynonym { td_synRhs = rhs_ty }) res_k
   = discardResult (tcCheckLHsType rhs_ty res_k)
 
@@ -757,17 +762,27 @@ tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside
 
          -- Kind-check and quantify
          -- See Note [Quantifying over family patterns]
-        ; (tkvs, typats) <- tcExtendTyVarEnv (map mkKindSigVar kvars) $
-                            tcHsTyVarBndrsGen (map (noLoc . UserTyVar) tvars) $ 
-             do { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds
-                ; kind_checker res_kind
-                ; return (tyVarsOfTypes typats, typats) }
-
-       ; all_args' <- zonkTcTypeToTypes emptyZonkEnv (fam_arg_kinds ++ typats)
-       ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind
-       ; traceTc "tcFamPats" (ppr tkvs $$ ppr all_args' $$ ppr res_kind')
-       ; tcExtendTyVarEnv tkvs $
-         thing_inside tkvs all_args' res_kind' }
+       ; typats <- tcExtendTyVarEnv (map mkKindSigVar kvars)      $
+                   tcHsTyVarBndrs (map (noLoc . UserTyVar) tvars) $ \ _ ->
+                   do { kind_checker res_kind
+                      ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds }
+       ; let all_args = fam_arg_kinds ++ typats
+
+            -- Find free variables (after zonking)
+       ; tkvs <- zonkTyVarsAndFV (tyVarsOfTypes all_args)
+
+            -- Turn them into skolems, so that we don't subsequently 
+            -- replace a meta kind var with AnyK
+       ; qtkvs <- zonkQuantifiedTyVars (varSetElems tkvs)
+
+            -- Zonk the patterns etc into the Type world
+       ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs
+       ; all_args'    <- zonkTcTypeToTypes ze all_args
+       ; res_kind'    <- zonkTcTypeToType  ze res_kind
+
+       ; traceTc "tcFamPats" (pprTvBndrs qtkvs' $$ ppr all_args' $$ ppr res_kind')
+       ; tcExtendTyVarEnv qtkvs' $
+         thing_inside qtkvs' all_args' res_kind' }
 \end{code}
 
 Note [Quantifying over family patterns]
@@ -810,7 +825,7 @@ Then in the family instance we want to
 Notice that in the third step we quantify over all the visibly-mentioned
 type variables (a,b), but also over the implicitly mentioned kind varaibles
 (k, k').  In this case one is bound explicitly but often there will be 
-none. The rold of the kind signature (a :: Maybe k) is to add a constraint
+none. The role of the kind signature (a :: Maybe k) is to add a constraint
 that 'a' must have that kind, and to bring 'k' into scope.
 
 Note [Associated type instances]
@@ -867,18 +882,18 @@ dataDeclChecks tc_name new_or_data stupid_theta cons
           -- Check that the stupid theta is empty for a GADT-style declaration
        ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
 
-       -- Check that a newtype has exactly one constructor
-       -- Do this before checking for empty data decls, so that
-       -- we don't suggest -XEmptyDataDecls for newtypes
-      ; checkTc (new_or_data == DataType || isSingleton cons) 
+        -- Check that a newtype has exactly one constructor
+        -- Do this before checking for empty data decls, so that
+        -- we don't suggest -XEmptyDataDecls for newtypes
+       ; checkTc (new_or_data == DataType || isSingleton cons) 
                (newtypeConError tc_name (length cons))
 
-       -- Check that there's at least one condecl,
-       -- or else we're reading an hs-boot file, or -XEmptyDataDecls
-      ; empty_data_decls <- xoptM Opt_EmptyDataDecls
-      ; is_boot <- tcIsHsBoot  -- Are we compiling an hs-boot file?
-      ; checkTc (not (null cons) || empty_data_decls || is_boot)
-                (emptyConDeclsErr tc_name) }
+               -- Check that there's at least one condecl,
+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+       ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+       ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+       ; checkTc (not (null cons) || empty_data_decls || is_boot)
+                 (emptyConDeclsErr tc_name) }
     
 -----------------------------------
 tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type)
@@ -895,46 +910,50 @@ tcConDecl :: NewOrData
 
 tcConDecl new_or_data existential_ok rep_tycon res_tmpl        -- Data types
          con@(ConDecl { con_name = name
-                       , con_qvars = tvs, con_cxt = ctxt
-                       , con_details = details, con_res = res_ty })
+                       , con_qvars = hs_tvs, con_cxt = hs_ctxt
+                       , con_details = hs_details, con_res = hs_res_ty })
   = addErrCtxt (dataConCtxt name) $
     do { traceTc "tcConDecl 1" (ppr name)
-       ; (tvs', (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) 
-           <- tcHsTyVarBndrsGen tvs $ 
-              do { ctxt'    <- tcHsContext ctxt
-                 ; details' <- tcConArgs new_or_data details
-                 ; res_ty'  <- tcConRes res_ty
-                 ; let (is_infix, field_lbls, btys') = details'
-                       (arg_tys', stricts)           = unzip btys'
-                       ftvs = tyVarsOfTypes ctxt'     `unionVarSet`
-                              tyVarsOfTypes arg_tys'  `unionVarSet`
-                              case res_ty' of
-                                 ResTyH98     -> emptyVarSet
-                                 ResTyGADT ty -> tyVarsOfType ty
-                 ; return (ftvs, (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) }
-
-
-             -- Substitute, to account for the kind 
-             -- unifications done by tcHsTyVarBndrsGen
-       ; traceTc "tcConDecl 2" (ppr name)
-       ; let ze = mkTyVarZonkEnv tvs'
-       ; arg_tys' <- zonkTcTypeToTypes ze arg_tys'
-       ; ctxt'    <- zonkTcTypeToTypes ze ctxt'
-       ; res_ty'  <- case res_ty' of
-                           ResTyH98     -> return ResTyH98
-                           ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty
+       ; (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) 
+           <- tcHsTyVarBndrs hs_tvs $ \ tvs ->
+              do { ctxt    <- tcHsContext hs_ctxt
+                 ; details <- tcConArgs new_or_data hs_details
+                 ; res_ty  <- tcConRes hs_res_ty
+                 ; let (is_infix, field_lbls, btys) = details
+                       (arg_tys, stricts)           = unzip btys
+                 ; return (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) }
+
+       ; let pretend_res_ty = case res_ty of
+                                ResTyH98     -> unitTy
+                                ResTyGADT ty -> ty
+             pretend_con_ty = mkSigmaTy tvs ctxt (mkFunTys arg_tys pretend_res_ty)
+                -- This pretend_con_ty stuff is just a convenient way to get the
+                -- free kind variables of the type, for kindGeneralize to work on
+
+             -- Generalise the kind variables (returning quantifed TcKindVars)
+             -- and quanify the type variables (substiting their kinds)
+       ; kvs <- kindGeneralize (tyVarsOfType pretend_con_ty)
+       ; tvs <- zonkQuantifiedTyVars tvs
+
+             -- Zonk to Types
+       ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (kvs ++ tvs)
+       ; arg_tys <- zonkTcTypeToTypes ze arg_tys
+       ; ctxt    <- zonkTcTypeToTypes ze ctxt
+       ; res_ty  <- case res_ty of
+                      ResTyH98     -> return ResTyH98
+                      ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty
 
        ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
                 (badExistential name)
 
-       ; let (univ_tvs, ex_tvs, eq_preds, res_ty'')
-                = rejigConRes res_tmpl tvs' res_ty'
+       ; let (univ_tvs, ex_tvs, eq_preds, res_ty')
+                = rejigConRes res_tmpl qtkvs res_ty
 
        ; traceTc "tcConDecl 3" (ppr name)
        ; buildDataCon (unLoc name) is_infix
                      stricts field_lbls
-                     univ_tvs ex_tvs eq_preds ctxt' arg_tys'
-                     res_ty'' rep_tycon
+                     univ_tvs ex_tvs eq_preds ctxt arg_tys
+                     res_ty' rep_tycon
                -- NB:  we put data_tc, the type constructor gotten from the
                --      constructor type signature into the data constructor;
                --      that way checkValidDataCon can complain if it's wrong.
@@ -1234,6 +1253,7 @@ checkValidTyCon tc
   = case synTyConRhs tc of
       SynFamilyTyCon {} -> return ()
       SynonymTyCon ty   -> checkValidType syn_ctxt ty
+
   | otherwise
   = do { -- Check the context on the data decl
        ; traceTc "cvtc1" (ppr tc)
@@ -1309,6 +1329,7 @@ checkValidDataCon tc con
         ; let tc_tvs = tyConTyVars tc
              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
              actual_res_ty = dataConOrigResTy con
+        ; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl)
        ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
                                res_ty_tmpl
                                actual_res_ty))
@@ -1320,7 +1341,14 @@ checkValidDataCon tc con
                -- Reason: it's really the argument of an equality constraint
        ; checkValidType ctxt (dataConUserType con)
        ; when (isNewTyCon tc) (checkNewDataCon con)
+
         ; mapM_ check_bang (dataConStrictMarks con `zip` [1..])
+
+        ; ASSERT2( not (any (isKindVar . fst) (dataConEqSpec con)), 
+                   ppr con $$ ppr (dataConEqSpec con) )
+               -- We don't support kind equalities, and shoud not be any
+          return ()
+
         ; traceTc "Done validity of data con" (ppr con <+> ppr (dataConRepType con))
     }
   where
@@ -1416,9 +1444,9 @@ checkValidClass cls
                -- type variable.  What a mess!
 
     check_at_defs (fam_tc, defs)
-      = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs
-           tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ 
-             mapM_ (check_loc_at_def fam_tc) defs
+      = do mapM_ (\(ATD _tvs pats rhs _loc) -> checkValidFamInst pats rhs) defs
+           tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ 
+             mapM_ (check_loc_at_def fam_tc) defs }
 
     check_loc_at_def fam_tc (ATD _tvs pats _rhs loc)
       -- Set the location for each of the default declarations
index 74b4e1a..b45824f 100644 (file)
@@ -152,7 +152,7 @@ module TcType (
   tyVarsOfType, tyVarsOfTypes,
   tcTyVarsOfType, tcTyVarsOfTypes,
 
-  pprKind, pprParendKind,
+  pprKind, pprParendKind, pprSigmaType,
   pprType, pprParendType, pprTypeApp, pprTyThingCategory,
   pprTheta, pprThetaArrowTy, pprClassPred
 
index d22fbda..6e4d128 100644 (file)
@@ -1087,8 +1087,12 @@ unifyKind :: TcKind           -- k1 (actual)
           -> TcM Ordering     -- Returns the relation between the kinds
                               -- LT <=> k1 is a sub-kind of k2
 
-unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2
-unifyKind k1 (TyVarTy kv2) = uKVar True  kv2 k1
+-- unifyKind deals with the top-level sub-kinding story
+-- but recurses into the simpler unifyKindEq for any sub-terms
+-- The sub-kinding stuff only applies at top level
+
+unifyKind (TyVarTy kv1) k2 = uKVar False unifyKind EQ kv1 k2
+unifyKind k1 (TyVarTy kv2) = uKVar True  unifyKind EQ kv2 k1
 
 unifyKind k1 k2       -- See Note [Expanding synonyms during unification]
   | Just k1' <- tcView k1 = unifyKind k1' k2
@@ -1103,24 +1107,44 @@ unifyKind k1@(TyConApp kc1 []) k2@(TyConApp kc2 [])
 unifyKind k1 k2 = do { unifyKindEq k1 k2; return EQ }
   -- In all other cases, let unifyKindEq do the work
 
-uKVar :: Bool -> MetaKindVar -> TcKind -> TcM Ordering
-uKVar isFlipped kv1 k2
-  | isMetaTyVar kv1
+uKVar :: Bool -> (TcKind -> TcKind -> TcM a) -> a
+      -> MetaKindVar -> TcKind -> TcM a
+uKVar isFlipped unify_kind eq_res kv1 k2
+  | isTcTyVar kv1, isMetaTyVar kv1       -- See Note [Unifying kind variables]
   = do  { mb_k1 <- readMetaTyVar kv1
         ; case mb_k1 of
-            Flexi -> uUnboundKVar kv1 k2 >> return EQ
-            Indirect k1 -> unifyKind k1 k2 }
-  | TyVarTy kv2 <- k2, isMetaTyVar kv2
-  = uKVar (not isFlipped) kv2 (TyVarTy kv1)
-  | TyVarTy kv2 <- k2, kv1 == kv2 = return EQ
+            Flexi -> do { uUnboundKVar kv1 k2; return eq_res }
+            Indirect k1 -> if isFlipped then unify_kind k2 k1
+                                        else unify_kind k1 k2 }
+  | TyVarTy kv2 <- k2, kv1 == kv2 
+  = return eq_res
+
+  | TyVarTy kv2 <- k2, isTcTyVar kv2, isMetaTyVar kv2
+  = uKVar (not isFlipped) unify_kind eq_res kv2 (TyVarTy kv1)
+
   | otherwise = if isFlipped 
                 then unifyKindMisMatch k2 (TyVarTy kv1)
                 else unifyKindMisMatch (TyVarTy kv1) k2
 
+{- Note [Unifying kind variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Rather hackily, kind variables can be TyVars not just TcTyVars.
+Main reason is in 
+   data instance T (D (x :: k)) = ...con-decls...
+Here we bring into scope a kind variable 'k', and use it in the 
+con-decls.  BUT the con-decls will be finished and frozen, and
+are not amenable to subsequent substitution, so it makes sense
+to have the *final* kind-variable (a KindVar, not a TcKindVar) in 
+scope.  So at least during kind unification we can encounter a
+KindVar. 
+
+Hence the isTcTyVar tests before using isMetaTyVar.
+-}
+
 ---------------------------
 unifyKindEq :: TcKind -> TcKind -> TcM ()
-unifyKindEq (TyVarTy kv1) k2 = uKVarEq False kv1 k2
-unifyKindEq k1 (TyVarTy kv2) = uKVarEq True  kv2 k1
+unifyKindEq (TyVarTy kv1) k2 = uKVar False unifyKindEq () kv1 k2
+unifyKindEq k1 (TyVarTy kv2) = uKVar True  unifyKindEq () kv2 k1
 
 unifyKindEq (FunTy a1 r1) (FunTy a2 r2)
   = do { unifyKindEq a1 a2; unifyKindEq r1 r2 }
@@ -1135,27 +1159,10 @@ unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s)
 unifyKindEq k1 k2 = unifyKindMisMatch k1 k2
 
 ----------------
--- For better error messages, we record whether we've flipped the kinds
--- during the process.
-uKVarEq :: Bool -> MetaKindVar -> TcKind -> TcM ()
-uKVarEq isFlipped kv1 k2
-  | isMetaTyVar kv1
-  = do  { mb_k1 <- readMetaTyVar kv1
-        ; case mb_k1 of
-            Flexi -> uUnboundKVar kv1 k2
-            Indirect k1 -> unifyKindEq k1 k2 }
-  | TyVarTy kv2 <- k2, isMetaTyVar kv2
-  = uKVarEq (not isFlipped) kv2 (TyVarTy kv1)
-  | TyVarTy kv2 <- k2, kv1 == kv2 = return ()
-  | otherwise = if isFlipped 
-                then unifyKindMisMatch k2 (TyVarTy kv1)
-                else unifyKindMisMatch (TyVarTy kv1) k2
-
-----------------
 uUnboundKVar :: MetaKindVar -> TcKind -> TcM ()
 uUnboundKVar kv1 k2@(TyVarTy kv2)
   | kv1 == kv2 = return ()
-  | isMetaTyVar kv2   -- Distinct kind variables
+  | isTcTyVar kv2, isMetaTyVar kv2   -- Distinct kind variables
   = do  { mb_k2 <- readMetaTyVar kv2
         ; case mb_k2 of
             Indirect k2 -> uUnboundKVar kv1 k2
index d2080bf..e28a3fb 100644 (file)
@@ -153,12 +153,8 @@ pprInstance ispec
 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
 pprInstanceHdr :: ClsInst -> SDoc
 -- Prints the ClsInst as an instance declaration
-pprInstanceHdr ispec@(ClsInst { is_flag = flag })
-  = ptext (sLit "instance") <+> ppr flag
-       <+> sep [pprThetaArrowTy theta, ppr res_ty]
-  where
-    dfun = is_dfun ispec
-    (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
+pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
+  = ptext (sLit "instance") <+> ppr flag <+> pprSigmaType (idType dfun)
         -- Print without the for-all, which the programmer doesn't write
 
 pprInstances :: [ClsInst] -> SDoc
index 1470160..e0de629 100644 (file)
@@ -135,7 +135,7 @@ module Type (
 
        -- * Pretty-printing
        pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, 
-        pprTvBndr, pprTvBndrs, pprForAll,
+        pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType,
        pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, 
         pprKind, pprParendKind, pprSourceTyCon,
     ) where
index 69637b3..605c97f 100644 (file)
@@ -38,7 +38,7 @@ module TypeRep (
         
         -- Pretty-printing
        pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
-       pprTyThing, pprTyThingCategory, 
+       pprTyThing, pprTyThingCategory, pprSigmaType,
        pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
         pprKind, pprParendKind, pprTyLit,
        Prec(..), maybeParen, pprTcApp, pprTypeNameApp, 
@@ -564,11 +564,11 @@ ppr_type :: Prec -> Type -> SDoc
 ppr_type _ (TyVarTy tv)              = ppr_tvar tv
 ppr_type p (TyConApp tc tys)  = pprTcApp p ppr_type tc tys
 ppr_type p (LitTy l)          = ppr_tylit p l
+ppr_type p ty@(ForAllTy {})   = ppr_forall_type p ty
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
                           pprType t1 <+> ppr_type TyConPrec t2
 
-ppr_type p ty@(ForAllTy {})        = ppr_forall_type p ty
 ppr_type p fun_ty@(FunTy ty1 ty2)
   | isPredTy ty1
   = ppr_forall_type p fun_ty
@@ -580,19 +580,10 @@ ppr_type p fun_ty@(FunTy ty1 ty2)
       | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
     ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
 
+
 ppr_forall_type :: Prec -> Type -> SDoc
 ppr_forall_type p ty
-  = maybeParen p FunPrec $
-    sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
-  where
-    (tvs,  rho) = split1 [] ty
-    (ctxt, tau) = split2 [] rho
-
-    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
-    split1 tvs ty          = (reverse tvs, ty)
-    split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
-    split2 ps ty                               = (reverse ps, ty)
+  = maybeParen p FunPrec $ (ppr_sigma_type True ty)
 
 ppr_tvar :: TyVar -> SDoc
 ppr_tvar tv  -- Note [Infix type variables]
@@ -605,6 +596,26 @@ ppr_tylit _ tl =
     StrTyLit s -> text (show s)
 
 -------------------
+ppr_sigma_type :: Bool -> Type -> SDoc
+-- Bool <=> Show the foralls
+ppr_sigma_type show_foralls ty
+  =  sep [ if show_foralls then pprForAll tvs else empty
+        , pprThetaArrowTy ctxt
+        , pprType tau ]
+  where
+    (tvs,  rho) = split1 [] ty
+    (ctxt, tau) = split2 [] rho
+
+    split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+    split1 tvs ty          = (reverse tvs, ty)
+    split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
+    split2 ps ty                               = (reverse ps, ty)
+
+
+pprSigmaType :: Type -> SDoc
+pprSigmaType ty = ppr_sigma_type opt_PprStyle_Debug ty
+
 pprForAll :: [TyVar] -> SDoc
 pprForAll []  = empty
 pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot
index 47dd779..8252621 100644 (file)
@@ -7,6 +7,7 @@ module Platform (
         OS(..),
         ArmISA(..),
         ArmISAExt(..),
+        ArmABI(..),
 
         target32Bit,
         osElfTarget
@@ -41,7 +42,9 @@ data Arch
         | ArchSPARC
         | ArchARM
           { armISA    :: ArmISA
-          , armISAExt :: [ArmISAExt] }
+          , armISAExt :: [ArmISAExt]
+          , armABI    :: ArmABI
+          }
         deriving (Read, Show, Eq)
 
 
@@ -61,7 +64,7 @@ data OS
         | OSHaiku
         deriving (Read, Show, Eq)
 
--- | ARM Instruction Set Architecture and Extensions
+-- | ARM Instruction Set Architecture, Extensions and ABI
 --
 data ArmISA
     = ARMv5
@@ -77,6 +80,11 @@ data ArmISAExt
     | IWMMX2
     deriving (Read, Show, Eq)
 
+data ArmABI
+    = SOFT
+    | SOFTFP
+    | HARD
+    deriving (Read, Show, Eq)
 
 target32Bit :: Platform -> Bool
 target32Bit p = platformWordSize p == 4
index 88fc947..8f6e321 100644 (file)
@@ -361,7 +361,7 @@ vectTopRhs recFs var expr
     rhs _globalScalar _isDFun (Just (_, expr'))               -- Case (1)
       = return (inlineMe, False, expr')
     rhs True          False   Nothing                         -- Case (2)
-      = do { expr' <- vectScalarFun True recFs expr
+      = do { expr' <- vectScalarFun recFs expr
            ; return (inlineMe, True, vectorised expr')
            }
     rhs True          True    Nothing                         -- Case (3)
index 36fe910..0764c3b 100644 (file)
@@ -689,14 +689,13 @@ vectDictExpr (Coercion coe)
 -- instead they become dictionaries of vectorised methods).  We treat them differently, though see
 -- "Note [Scalar dfuns]" in 'Vectorise'.
 --
-vectScalarFun :: Bool       -- ^ Was the function marked as scalar by the user?
-              -> [Var]      -- ^ Functions names in same recursive binding group
+vectScalarFun :: [Var]      -- ^ Functions names in same recursive binding group
               -> CoreExpr   -- ^ Expression to be vectorised
               -> VM VExpr
-vectScalarFun forceScalar recFns expr 
- = vectScalarFunVT forceScalar recFns expr (VITNode VISimple [])
-
-
+vectScalarFun recFns expr 
+ -- this is an external call to vectScalarFun, so we pass a dummy vt tree. The only
+ -- relevant bit is that the node info is *not* VIEncaps
+ = vectScalarFunVT True recFns expr (VITNode VISimple []) 
 
 
 vectScalarFunVT :: Bool       -- ^ Was the function marked as scalar by the user?
@@ -715,34 +714,24 @@ vectScalarFunVT forceScalar recFns expr (VITNode vi _)
                    "\n\tresult  scalar?    : " ++ (show $is_scalar_ty scalarTyCons res_ty) ++
                    "\n\tscalar body?       : " ++ (show $is_scalar scalarVars (is_scalar_ty scalarTyCons) expr) ++
                    "\n\tuses vars?         : " ++ (show $uses scalarVars expr) ++
-                   "\n\t is encaps?        : " ++ (show vi)
+                   "\n\t is encaps? (same as & of all prev cond): " ++ (show vi)
                   )
            (ppr expr)
        ; onlyIfV (ptext (sLit "not a scalar function"))
                  (forceScalar                              -- user asserts the functions is scalar
                   ||
-                  (vi == VIEncaps)                         -- should only be true if all the foll. cond are hold
-                  ||
+                  (vi == VIEncaps))                         -- should only be true if all the foll. cond are hold
+
+{-                  ||
                   all (is_scalar_ty scalarTyCons) arg_tys  -- check whether the function is scalar
                    && is_scalar_ty scalarTyCons res_ty
                    && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr
                    && uses scalarVars expr)
+ -}
          $ do { traceVt  "vectScalarFun - is scalar"  (ppr expr) 
               ;  mkScalarFun arg_tys res_ty expr
               }
        }      
-{-
-      ; onlyIfV (ptext (sLit "not a scalar function"))
-                (forceScalar                                 -- user asserts the functions is scalar
-                 ||
-                 all is_primitive_ty arg_tys                 -- check whether the function is scalar
-                  && is_primitive_ty res_ty
-                  && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr
-                  && uses scalarVars expr
-                  && length arg_tys <= mAX_DPH_SCALAR_ARGS)
-        $ mkScalarFun arg_tys res_ty expr
-      }
-      -}
   where
     {-
     -- !!!FIXME: We would like to allow scalar functions with arguments and results that can be
@@ -912,7 +901,7 @@ vectScalarDFun var recFns
              dict           = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars
              scsOps         = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict])
                                   selIds
-       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun True recFns e) scsOps
+       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun recFns e) scsOps
 
            -- vectorised applications of the class-dictionary data constructor
        ; Just vDataCon <- lookupDataCon dataCon
@@ -1181,8 +1170,8 @@ vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits))
 vectAlgCase tycon _ty_args _scrut _bndr _ty _alts (VITNode _ [])
   = pprPanic "vectAlgCase (mismatched node information)" (ppr tycon)
 
----- Sanity check  of the 
 {-
+---- Sanity check  of the tree, for debugging only
 checkTree :: VITree -> CoreExpr -> Bool
 checkTree  (VITNode _ []) (Type _ty) 
   = True
index 463a03a..d622a44 100644 (file)
@@ -1,10 +1,10 @@
 #! /bin/sh
 # Attempt to guess a canonical system name.
 #   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
-#   Free Software Foundation, Inc.
+#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+#   2011, 2012 Free Software Foundation, Inc.
 
-timestamp='2008-11-15'
+timestamp='2012-02-10'
 
 # This file is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
@@ -17,9 +17,7 @@ timestamp='2008-11-15'
 # General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
-# 02110-1301, USA.
+# along with this program; if not, see <http://www.gnu.org/licenses/>.
 #
 # As a special exception to the GNU General Public License, if you
 # distribute this file as part of a program that contains a
@@ -27,16 +25,16 @@ timestamp='2008-11-15'
 # the same distribution terms that you use for the rest of that program.
 
 
-# Originally written by Per Bothner <per@bothner.com>.
-# Please send patches to <config-patches@gnu.org>.  Submit a context
-# diff and a properly formatted ChangeLog entry.
+# Originally written by Per Bothner.  Please send patches (context
+# diff format) to <config-patches@gnu.org> and include a ChangeLog
+# entry.
 #
 # This script attempts to guess a canonical system name similar to
 # config.sub.  If it succeeds, it prints the system name on stdout, and
 # exits with 0.  Otherwise, it exits with 1.
 #
-# The plan is that this can be called by configure scripts if you
-# don't specify an explicit build system type.
+# You can get the latest version of this script from:
+# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
 
 me=`echo "$0" | sed -e 's,.*/,,'`
 
@@ -56,8 +54,9 @@ version="\
 GNU config.guess ($timestamp)
 
 Originally written by Per Bothner.
-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+Free Software Foundation, Inc.
 
 This is free software; see the source for copying conditions.  There is NO
 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@@ -144,7 +143,7 @@ UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
 case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
     *:NetBSD:*:*)
        # NetBSD (nbsd) targets should (where applicable) match one or
-       # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*,
+       # more of the tuples: *-*-netbsdelf*, *-*-netbsdaout*,
        # *-*-netbsdecoff* and *-*-netbsd*.  For targets that recently
        # switched to ELF, *-*-netbsd* would select the old
        # object file format.  This provides both forward
@@ -170,7 +169,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
            arm*|i386|m68k|ns32k|sh3*|sparc|vax)
                eval $set_cc_for_build
                if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
-                       | grep __ELF__ >/dev/null
+                       | grep -q __ELF__
                then
                    # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
                    # Return netbsd for either.  FIX?
@@ -180,7 +179,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
                fi
                ;;
            *)
-               os=netbsd
+               os=netbsd
                ;;
        esac
        # The OS release
@@ -223,7 +222,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
                UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
                ;;
        *5.*)
-               UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
+               UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
                ;;
        esac
        # According to Compaq, /usr/sbin/psrinfo has been available on
@@ -269,7 +268,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        # A Xn.n version is an unreleased experimental baselevel.
        # 1.2 uses "1.2" for uname -r.
        echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
-       exit ;;
+       # Reset EXIT trap before exiting to avoid spurious non-zero exit code.
+       exitcode=$?
+       trap '' 0
+       exit $exitcode ;;
     Alpha\ *:Windows_NT*:*)
        # How do we know it's Interix rather than the generic POSIX subsystem?
        # Should we change UNAME_MACHINE based on the output of uname instead
@@ -295,7 +297,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        echo s390-ibm-zvmoe
        exit ;;
     *:OS400:*:*)
-        echo powerpc-ibm-os400
+       echo powerpc-ibm-os400
        exit ;;
     arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
        echo arm-acorn-riscix${UNAME_RELEASE}
@@ -324,12 +326,18 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        case `/usr/bin/uname -p` in
            sparc) echo sparc-icl-nx7; exit ;;
        esac ;;
+    s390x:SunOS:*:*)
+       echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+       exit ;;
     sun4H:SunOS:5.*:*)
        echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
        exit ;;
     sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
        echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
        exit ;;
+    i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*)
+       echo i386-pc-auroraux${UNAME_RELEASE}
+       exit ;;
     i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
        eval $set_cc_for_build
        SUN_ARCH="i386"
@@ -337,17 +345,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        # Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
        # This test works for both compilers.
        if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
-            # bash is not able to generate correct code here
-            # i.e. it leaves \ns there
-            # so we need to use /usr/bin/echo to get what we want
-            # note that if config.guess is run by /bin/sh then
-            # this works as expected even without /usr/bin/echo
-            # but the problem is that configure is clever enough
-            # to find bash installed and then runs config.guess
-            # by bash instead of by /bin/sh
-            # It seems that using /usr/bin/echo here is the most
-            # portable Solaris fix
-           if /usr/bin/echo '\n#ifdef __amd64\nIS_64BIT_ARCH\n#endif' | \
+           if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
                (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
                grep IS_64BIT_ARCH >/dev/null
            then
@@ -398,23 +396,23 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
     # MiNT.  But MiNT is downward compatible to TOS, so this should
     # be no problem.
     atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
-        echo m68k-atari-mint${UNAME_RELEASE}
+       echo m68k-atari-mint${UNAME_RELEASE}
        exit ;;
     atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
        echo m68k-atari-mint${UNAME_RELEASE}
-        exit ;;
+       exit ;;
     *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
-        echo m68k-atari-mint${UNAME_RELEASE}
+       echo m68k-atari-mint${UNAME_RELEASE}
        exit ;;
     milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
-        echo m68k-milan-mint${UNAME_RELEASE}
-        exit ;;
+       echo m68k-milan-mint${UNAME_RELEASE}
+       exit ;;
     hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
-        echo m68k-hades-mint${UNAME_RELEASE}
-        exit ;;
+       echo m68k-hades-mint${UNAME_RELEASE}
+       exit ;;
     *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
-        echo m68k-unknown-mint${UNAME_RELEASE}
-        exit ;;
+       echo m68k-unknown-mint${UNAME_RELEASE}
+       exit ;;
     m68k:machten:*:*)
        echo m68k-apple-machten${UNAME_RELEASE}
        exit ;;
@@ -484,8 +482,8 @@ EOF
        echo m88k-motorola-sysv3
        exit ;;
     AViiON:dgux:*:*)
-        # DG/UX returns AViiON for all architectures
-        UNAME_PROCESSOR=`/usr/bin/uname -p`
+       # DG/UX returns AViiON for all architectures
+       UNAME_PROCESSOR=`/usr/bin/uname -p`
        if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
        then
            if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
@@ -498,7 +496,7 @@ EOF
        else
            echo i586-dg-dgux${UNAME_RELEASE}
        fi
-       exit ;;
+       exit ;;
     M88*:DolphinOS:*:*)        # DolphinOS (SVR3)
        echo m88k-dolphin-sysv3
        exit ;;
@@ -555,7 +553,7 @@ EOF
                echo rs6000-ibm-aix3.2
        fi
        exit ;;
-    *:AIX:*:[456])
+    *:AIX:*:[4567])
        IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
        if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
                IBM_ARCH=rs6000
@@ -598,52 +596,52 @@ EOF
            9000/[678][0-9][0-9])
                if [ -x /usr/bin/getconf ]; then
                    sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
-                    sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
-                    case "${sc_cpu_version}" in
-                      523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
-                      528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
-                      532)                      # CPU_PA_RISC2_0
-                        case "${sc_kernel_bits}" in
-                          32) HP_ARCH="hppa2.0n" ;;
-                          64) HP_ARCH="hppa2.0w" ;;
+                   sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
+                   case "${sc_cpu_version}" in
+                     523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
+                     528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
+                     532)                      # CPU_PA_RISC2_0
+                       case "${sc_kernel_bits}" in
+                         32) HP_ARCH="hppa2.0n" ;;
+                         64) HP_ARCH="hppa2.0w" ;;
                          '') HP_ARCH="hppa2.0" ;;   # HP-UX 10.20
-                        esac ;;
-                    esac
+                       esac ;;
+                   esac
                fi
                if [ "${HP_ARCH}" = "" ]; then
                    eval $set_cc_for_build
-                   sed 's/^              //' << EOF >$dummy.c
+                   sed 's/^            //' << EOF >$dummy.c
 
-              #define _HPUX_SOURCE
-              #include <stdlib.h>
-              #include <unistd.h>
+               #define _HPUX_SOURCE
+               #include <stdlib.h>
+               #include <unistd.h>
 
-              int main ()
-              {
-              #if defined(_SC_KERNEL_BITS)
-                  long bits = sysconf(_SC_KERNEL_BITS);
-              #endif
-                  long cpu  = sysconf (_SC_CPU_VERSION);
+               int main ()
+               {
+               #if defined(_SC_KERNEL_BITS)
+                   long bits = sysconf(_SC_KERNEL_BITS);
+               #endif
+                   long cpu  = sysconf (_SC_CPU_VERSION);
 
-                  switch (cpu)
-               {
-               case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
-               case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
-               case CPU_PA_RISC2_0:
-              #if defined(_SC_KERNEL_BITS)
-                   switch (bits)
-                       {
-                       case 64: puts ("hppa2.0w"); break;
-                       case 32: puts ("hppa2.0n"); break;
-                       default: puts ("hppa2.0"); break;
-                       } break;
-              #else  /* !defined(_SC_KERNEL_BITS) */
-                   puts ("hppa2.0"); break;
-              #endif
-               default: puts ("hppa1.0"); break;
-               }
-                  exit (0);
-              }
+                   switch (cpu)
+                       {
+                       case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
+                       case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
+                       case CPU_PA_RISC2_0:
+               #if defined(_SC_KERNEL_BITS)
+                           switch (bits)
+                               {
+                               case 64: puts ("hppa2.0w"); break;
+                               case 32: puts ("hppa2.0n"); break;
+                               default: puts ("hppa2.0"); break;
+                               } break;
+               #else  /* !defined(_SC_KERNEL_BITS) */
+                           puts ("hppa2.0"); break;
+               #endif
+                       default: puts ("hppa1.0"); break;
+                       }
+                   exit (0);
+               }
 EOF
                    (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
                    test -z "$HP_ARCH" && HP_ARCH=hppa
@@ -663,7 +661,7 @@ EOF
            # => hppa64-hp-hpux11.23
 
            if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
-               grep __LP64__ >/dev/null
+               grep -q __LP64__
            then
                HP_ARCH="hppa2.0w"
            else
@@ -734,22 +732,22 @@ EOF
        exit ;;
     C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
        echo c1-convex-bsd
-        exit ;;
+       exit ;;
     C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
        if getsysinfo -f scalar_acc
        then echo c32-convex-bsd
        else echo c2-convex-bsd
        fi
-        exit ;;
+       exit ;;
     C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
        echo c34-convex-bsd
-        exit ;;
+       exit ;;
     C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
        echo c38-convex-bsd
-        exit ;;
+       exit ;;
     C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
        echo c4-convex-bsd
-        exit ;;
+       exit ;;
     CRAY*Y-MP:*:*:*)
        echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
        exit ;;
@@ -773,14 +771,14 @@ EOF
        exit ;;
     F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
        FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
-        FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
-        FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
-        echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
-        exit ;;
+       FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+       FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+       echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+       exit ;;
     5000:UNIX_System_V:4.*:*)
-        FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
-        FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
-        echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+       FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+       FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
+       echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
        exit ;;
     i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
        echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
@@ -792,13 +790,12 @@ EOF
        echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
        exit ;;
     *:FreeBSD:*:*)
-       case ${UNAME_MACHINE} in
-           pc98)
-               echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+       UNAME_PROCESSOR=`/usr/bin/uname -p`
+       case ${UNAME_PROCESSOR} in
            amd64)
                echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
            *)
-               echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+               echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
        esac
        exit ;;
     i*:CYGWIN*:*)
@@ -807,19 +804,22 @@ EOF
     *:MINGW*:*)
        echo ${UNAME_MACHINE}-pc-mingw32
        exit ;;
+    i*:MSYS*:*)
+       echo ${UNAME_MACHINE}-pc-msys
+       exit ;;
     i*:windows32*:*)
-       # uname -m includes "-pc" on this system.
-       echo ${UNAME_MACHINE}-mingw32
+       # uname -m includes "-pc" on this system.
+       echo ${UNAME_MACHINE}-mingw32
        exit ;;
     i*:PW*:*)
        echo ${UNAME_MACHINE}-pc-pw32
        exit ;;
-    *:Interix*:[3456]*)
-       case ${UNAME_MACHINE} in
+    *:Interix*:*)
+       case ${UNAME_MACHINE} in
            x86)
                echo i586-pc-interix${UNAME_RELEASE}
                exit ;;
-           EM64T | authenticamd | genuineintel)
+           authenticamd | genuineintel | EM64T)
                echo x86_64-unknown-interix${UNAME_RELEASE}
                exit ;;
            IA64)
@@ -829,6 +829,9 @@ EOF
     [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
        echo i${UNAME_MACHINE}-pc-mks
        exit ;;
+    8664:Windows_NT:*)
+       echo x86_64-pc-mks
+       exit ;;
     i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
        # How do we know it's Interix rather than the generic POSIX subsystem?
        # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
@@ -858,6 +861,27 @@ EOF
     i*86:Minix:*:*)
        echo ${UNAME_MACHINE}-pc-minix
        exit ;;
+    aarch64:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    aarch64_be:Linux:*:*)
+       UNAME_MACHINE=aarch64_be
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    alpha:Linux:*:*)
+       case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+         EV5)   UNAME_MACHINE=alphaev5 ;;
+         EV56)  UNAME_MACHINE=alphaev56 ;;
+         PCA56) UNAME_MACHINE=alphapca56 ;;
+         PCA57) UNAME_MACHINE=alphapca56 ;;
+         EV6)   UNAME_MACHINE=alphaev6 ;;
+         EV67)  UNAME_MACHINE=alphaev67 ;;
+         EV68*) UNAME_MACHINE=alphaev68 ;;
+       esac
+       objdump --private-headers /bin/sh | grep -q ld.so.1
+       if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+       echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+       exit ;;
     arm*:Linux:*:*)
        eval $set_cc_for_build
        if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
@@ -865,20 +889,40 @@ EOF
        then
            echo ${UNAME_MACHINE}-unknown-linux-gnu
        else
-           echo ${UNAME_MACHINE}-unknown-linux-gnueabi
+           if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \
+               | grep -q __ARM_PCS_VFP
+           then
+               echo ${UNAME_MACHINE}-unknown-linux-gnueabi
+           else
+               echo ${UNAME_MACHINE}-unknown-linux-gnueabihf
+           fi
        fi
        exit ;;
     avr32*:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
     cris:Linux:*:*)
-       echo cris-axis-linux-gnu
+       echo ${UNAME_MACHINE}-axis-linux-gnu
        exit ;;
     crisv32:Linux:*:*)
-       echo crisv32-axis-linux-gnu
+       echo ${UNAME_MACHINE}-axis-linux-gnu
        exit ;;
     frv:Linux:*:*)
-       echo frv-unknown-linux-gnu
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    hexagon:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    i*86:Linux:*:*)
+       LIBC=gnu
+       eval $set_cc_for_build
+       sed 's/^        //' << EOF >$dummy.c
+       #ifdef __dietlibc__
+       LIBC=dietlibc
+       #endif
+EOF
+       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'`
+       echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
        exit ;;
     ia64:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
@@ -889,78 +933,34 @@ EOF
     m68*:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
-    mips:Linux:*:*)
-       eval $set_cc_for_build
-       sed 's/^        //' << EOF >$dummy.c
-       #undef CPU
-       #undef mips
-       #undef mipsel
-       #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
-       CPU=mipsel
-       #else
-       #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
-       CPU=mips
-       #else
-       CPU=
-       #endif
-       #endif
-EOF
-       eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
-           /^CPU/{
-               s: ::g
-               p
-           }'`"
-       test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
-       ;;
-    mips64:Linux:*:*)
+    mips:Linux:*:* | mips64:Linux:*:*)
        eval $set_cc_for_build
        sed 's/^        //' << EOF >$dummy.c
        #undef CPU
-       #undef mips64
-       #undef mips64el
+       #undef ${UNAME_MACHINE}
+       #undef ${UNAME_MACHINE}el
        #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
-       CPU=mips64el
+       CPU=${UNAME_MACHINE}el
        #else
        #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
-       CPU=mips64
+       CPU=${UNAME_MACHINE}
        #else
        CPU=
        #endif
        #endif
 EOF
-       eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
-           /^CPU/{
-               s: ::g
-               p
-           }'`"
+       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'`
        test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
        ;;
     or32:Linux:*:*)
-       echo or32-unknown-linux-gnu
-       exit ;;
-    ppc:Linux:*:*)
-       echo powerpc-unknown-linux-gnu
-       exit ;;
-    ppc64:Linux:*:*)
-       echo powerpc64-unknown-linux-gnu
-       exit ;;
-    alpha:Linux:*:*)
-       case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
-         EV5)   UNAME_MACHINE=alphaev5 ;;
-         EV56)  UNAME_MACHINE=alphaev56 ;;
-         PCA56) UNAME_MACHINE=alphapca56 ;;
-         PCA57) UNAME_MACHINE=alphapca56 ;;
-         EV6)   UNAME_MACHINE=alphaev6 ;;
-         EV67)  UNAME_MACHINE=alphaev67 ;;
-         EV68*) UNAME_MACHINE=alphaev68 ;;
-        esac
-       objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null
-       if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
-       echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
     padre:Linux:*:*)
        echo sparc-unknown-linux-gnu
        exit ;;
+    parisc64:Linux:*:* | hppa64:Linux:*:*)
+       echo hppa64-unknown-linux-gnu
+       exit ;;
     parisc:Linux:*:* | hppa:Linux:*:*)
        # Look for CPU level
        case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
@@ -969,14 +969,17 @@ EOF
          *)    echo hppa-unknown-linux-gnu ;;
        esac
        exit ;;
-    parisc64:Linux:*:* | hppa64:Linux:*:*)
-       echo hppa64-unknown-linux-gnu
+    ppc64:Linux:*:*)
+       echo powerpc64-unknown-linux-gnu
+       exit ;;
+    ppc:Linux:*:*)
+       echo powerpc-unknown-linux-gnu
        exit ;;
     s390:Linux:*:* | s390x:Linux:*:*)
        echo ${UNAME_MACHINE}-ibm-linux
        exit ;;
     sh64*:Linux:*:*)
-       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
     sh*:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
@@ -984,75 +987,18 @@ EOF
     sparc:Linux:*:* | sparc64:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
+    tile*:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
     vax:Linux:*:*)
        echo ${UNAME_MACHINE}-dec-linux-gnu
        exit ;;
     x86_64:Linux:*:*)
-       echo x86_64-unknown-linux-gnu
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
     xtensa*:Linux:*:*)
-       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
        exit ;;
-    i*86:Linux:*:*)
-       # The BFD linker knows what the default object file format is, so
-       # first see if it will tell us. cd to the root directory to prevent
-       # problems with other programs or directories called `ld' in the path.
-       # Set LC_ALL=C to ensure ld outputs messages in English.
-       ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \
-                        | sed -ne '/supported targets:/!d
-                                   s/[         ][      ]*/ /g
-                                   s/.*supported targets: *//
-                                   s/ .*//
-                                   p'`
-        case "$ld_supported_targets" in
-         elf32-i386)
-               TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
-               ;;
-         a.out-i386-linux)
-               echo "${UNAME_MACHINE}-pc-linux-gnuaout"
-               exit ;;
-         "")
-               # Either a pre-BFD a.out linker (linux-gnuoldld) or
-               # one that does not give us useful --help.
-               echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
-               exit ;;
-       esac
-       # Determine whether the default compiler is a.out or elf
-       eval $set_cc_for_build
-       sed 's/^        //' << EOF >$dummy.c
-       #include <features.h>
-       #ifdef __ELF__
-       # ifdef __GLIBC__
-       #  if __GLIBC__ >= 2
-       LIBC=gnu
-       #  else
-       LIBC=gnulibc1
-       #  endif
-       # else
-       LIBC=gnulibc1
-       # endif
-       #else
-       #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC)
-       LIBC=gnu
-       #else
-       LIBC=gnuaout
-       #endif
-       #endif
-       #ifdef __dietlibc__
-       LIBC=dietlibc
-       #endif
-EOF
-       eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n '
-           /^LIBC/{
-               s: ::g
-               p
-           }'`"
-       test x"${LIBC}" != x && {
-               echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
-               exit
-       }
-       test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; }
-       ;;
     i*86:DYNIX/ptx:4*:*)
        # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
        # earlier versions are messed up and put the nodename in both
@@ -1060,11 +1006,11 @@ EOF
        echo i386-sequent-sysv4
        exit ;;
     i*86:UNIX_SV:4.2MP:2.*)
-        # Unixware is an offshoot of SVR4, but it has its own version
-        # number series starting with 2...
-        # I am not positive that other SVR4 systems won't match this,
+       # Unixware is an offshoot of SVR4, but it has its own version
+       # number series starting with 2...
+       # I am not positive that other SVR4 systems won't match this,
        # I just have to hope.  -- rms.
-        # Use sysv4.2uw... so that sysv4* matches it.
+       # Use sysv4.2uw... so that sysv4* matches it.
        echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
        exit ;;
     i*86:OS/2:*:*)
@@ -1081,7 +1027,7 @@ EOF
     i*86:syllable:*:*)
        echo ${UNAME_MACHINE}-pc-syllable
        exit ;;
-    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
+    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)
        echo i386-unknown-lynxos${UNAME_RELEASE}
        exit ;;
     i*86:*DOS:*:*)
@@ -1096,7 +1042,7 @@ EOF
        fi
        exit ;;
     i*86:*:5:[678]*)
-       # UnixWare 7.x, OpenUNIX and OpenServer 6.
+       # UnixWare 7.x, OpenUNIX and OpenServer 6.
        case `/bin/uname -X | grep "^Machine"` in
            *486*)           UNAME_MACHINE=i486 ;;
            *Pentium)        UNAME_MACHINE=i586 ;;
@@ -1124,10 +1070,13 @@ EOF
        exit ;;
     pc:*:*:*)
        # Left here for compatibility:
-        # uname -m prints for DJGPP always 'pc', but it prints nothing about
-        # the processor, so we play safe by assuming i386.
-       echo i386-pc-msdosdjgpp
-        exit ;;
+       # uname -m prints for DJGPP always 'pc', but it prints nothing about
+       # the processor, so we play safe by assuming i586.
+       # Note: whatever this is, it MUST be the same as what config.sub
+       # prints for the "djgpp" host, or else GDB configury will decide that
+       # this is a cross-build.
+       echo i586-pc-msdosdjgpp
+       exit ;;
     Intel:Mach:3*:*)
        echo i386-pc-mach3
        exit ;;
@@ -1162,8 +1111,18 @@ EOF
        /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
          && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
     3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
-        /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
-          && { echo i486-ncr-sysv4; exit; } ;;
+       /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+         && { echo i486-ncr-sysv4; exit; } ;;
+    NCR*:*:4.2:* | MPRAS*:*:4.2:*)
+       OS_REL='.3'
+       test -r /etc/.relid \
+           && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+       /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+           && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+       /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+           && { echo i586-ncr-sysv4.3${OS_REL}; exit; }
+       /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \
+           && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
     m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
        echo m68k-unknown-lynxos${UNAME_RELEASE}
        exit ;;
@@ -1176,7 +1135,7 @@ EOF
     rs6000:LynxOS:2.*:*)
        echo rs6000-unknown-lynxos${UNAME_RELEASE}
        exit ;;
-    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
+    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)
        echo powerpc-unknown-lynxos${UNAME_RELEASE}
        exit ;;
     SM[BE]S:UNIX_SV:*:*)
@@ -1196,10 +1155,10 @@ EOF
                echo ns32k-sni-sysv
        fi
        exit ;;
-    PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
-                      # says <Richard.M.Bartel@ccMail.Census.GOV>
-        echo i586-unisys-sysv4
-        exit ;;
+    PENTIUM:*:4.0*:*)  # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+                       # says <Richard.M.Bartel@ccMail.Census.GOV>
+       echo i586-unisys-sysv4
+       exit ;;
     *:UNIX_System_V:4*:FTX*)
        # From Gerald Hewes <hewes@openmarket.com>.
        # How about differentiating between stratus architectures? -djm
@@ -1225,11 +1184,11 @@ EOF
        exit ;;
     R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
        if [ -d /usr/nec ]; then
-               echo mips-nec-sysv${UNAME_RELEASE}
+               echo mips-nec-sysv${UNAME_RELEASE}
        else
-               echo mips-unknown-sysv${UNAME_RELEASE}
+               echo mips-unknown-sysv${UNAME_RELEASE}
        fi
-        exit ;;
+       exit ;;
     BeBox:BeOS:*:*)    # BeOS running on hardware made by Be, PPC only.
        echo powerpc-be-beos
        exit ;;
@@ -1269,6 +1228,16 @@ EOF
     *:Darwin:*:*)
        UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
        case $UNAME_PROCESSOR in
+           i386)
+               eval $set_cc_for_build
+               if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
+                 if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
+                     (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
+                     grep IS_64BIT_ARCH >/dev/null
+                 then
+                     UNAME_PROCESSOR="x86_64"
+                 fi
+               fi ;;
            unknown) UNAME_PROCESSOR=powerpc ;;
        esac
        echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
@@ -1284,6 +1253,9 @@ EOF
     *:QNX:*:4*)
        echo i386-pc-qnx
        exit ;;
+    NEO-?:NONSTOP_KERNEL:*:*)
+       echo neo-tandem-nsk${UNAME_RELEASE}
+       exit ;;
     NSE-?:NONSTOP_KERNEL:*:*)
        echo nse-tandem-nsk${UNAME_RELEASE}
        exit ;;
@@ -1329,13 +1301,13 @@ EOF
        echo pdp10-unknown-its
        exit ;;
     SEI:*:*:SEIUX)
-        echo mips-sei-seiux${UNAME_RELEASE}
+       echo mips-sei-seiux${UNAME_RELEASE}
        exit ;;
     *:DragonFly:*:*)
        echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
        exit ;;
     *:*VMS:*:*)
-       UNAME_MACHINE=`(uname -p) 2>/dev/null`
+       UNAME_MACHINE=`(uname -p) 2>/dev/null`
        case "${UNAME_MACHINE}" in
            A*) echo alpha-dec-vms ; exit ;;
            I*) echo ia64-dec-vms ; exit ;;
@@ -1350,6 +1322,12 @@ EOF
     i*86:rdos:*:*)
        echo ${UNAME_MACHINE}-pc-rdos
        exit ;;
+    i*86:AROS:*:*)
+       echo ${UNAME_MACHINE}-pc-aros
+       exit ;;
+    x86_64:VMkernel:*:*)
+       echo ${UNAME_MACHINE}-unknown-esx
+       exit ;;
 esac
 
 #echo '(No uname command or uname output not recognized.)' 1>&2
@@ -1372,11 +1350,11 @@ main ()
 #include <sys/param.h>
   printf ("m68k-sony-newsos%s\n",
 #ifdef NEWSOS4
-          "4"
+       "4"
 #else
-         ""
+       ""
 #endif
-         ); exit (0);
+       ); exit (0);
 #endif
 #endif
 
index 9237c77..8e3d9d2 100644 (file)
@@ -210,6 +210,20 @@ AC_CANONICAL_BUILD
 AC_CANONICAL_HOST
 AC_CANONICAL_TARGET
 
+# Testing ARM ABI
+# required for code generation (LLVM options)
+ARM_ABI=SOFT
+echo HOST: $host
+
+case $host in
+     arm*-*-linux-gnueabihf)
+     ARM_ABI=HARD
+     ;;
+     arm*-*-linux-gnueabi)
+     ARM_ABI=SOFTFP
+     ;;
+esac
+
 FPTOOLS_SET_PLATFORM_VARS
 
 # Verify that the installed (bootstrap) GHC is capable of generating
index f9cbeb1..265bf85 100644 (file)
@@ -954,7 +954,8 @@ test.hs:(5,4)-(6,7):
     <option>-fwarn-missing-fields</option>,
     <option>-fwarn-missing-methods</option>,
     <option>-fwarn-lazy-unlifted-bindings</option>,
-    <option>-fwarn-wrong-do-bind</option>, and
+    <option>-fwarn-wrong-do-bind</option>,
+    <option>-fwarn-unsupported-calling-conventions</option>, and
     <option>-fwarn-dodgy-foreign-imports</option>.  The following
     flags are
     simple ways to select standard &ldquo;packages&rdquo; of warnings:
@@ -988,9 +989,10 @@ test.hs:(5,4)-(6,7):
             <option>-fwarn-incomplete-uni-patterns</option>,
             <option>-fwarn-incomplete-record-updates</option>,
             <option>-fwarn-monomorphism-restriction</option>,
-            <option>-fwarn-unrecognised-pragmas</option>,
             <option>-fwarn-auto-orphans</option>,
-            <option>-fwarn-implicit-prelude</option>.</para>
+            <option>-fwarn-implicit-prelude</option>,
+            <option>-fwarn-missing-local-sigs</option>,
+            <option>-fwarn-missing-import-lists</option>.</para>
         </listitem>
       </varlistentry>
 
@@ -1103,6 +1105,19 @@ test.hs:(5,4)-(6,7):
       </varlistentry>
 
       <varlistentry>
+        <term><option>-fwarn-unsupported-calling-conventions</option>:</term>
+        <listitem>
+          <indexterm><primary><option>-fwarn-unsupported-calling-conventions</option></primary>
+          </indexterm>
+          <para>Causes a warning to be emitted for foreign declarations
+          that use unsupported calling conventions. In particular,
+          if the <literal>stdcall</literal> calling convention is used
+          on an architecture other than i386 then it will be treated
+          as <literal>ccall</literal>.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
         <term><option>-fwarn-dodgy-foreign-imports</option>:</term>
         <listitem>
           <indexterm><primary><option>-fwarn-dodgy-foreign-imports</option></primary>
diff --git a/ghc.mk b/ghc.mk
index d975425..e0797ee 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -1234,7 +1234,7 @@ distclean : clean
        $(call removeFiles,libraries/process/include/HsProcessConfig.h)
        $(call removeFiles,libraries/unix/include/HsUnixConfig.h)
        $(call removeFiles,libraries/old-time/include/HsTimeConfig.h)
-       $(call removeTrees,utils/ghc-pwd/dist)
+       $(call removeTrees,utils/ghc-pwd/dist-boot)
        $(call removeTrees,inplace)
        $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2)))
 
index 75e8ca0..9b28d0a 100644 (file)
@@ -1632,12 +1632,19 @@ moduleCmd str
 --   (d) import <module>...:   addImportToContext
 
 addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
-addModulesToContext starred unstarred = do
+addModulesToContext starred unstarred = restoreContextOnFailure $ do
+   addModulesToContext_ starred unstarred
+
+addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
+addModulesToContext_ starred unstarred = do
    mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
    setGHCContextFromGHCiState
 
 remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
 remModulesFromContext  starred unstarred = do
+   -- we do *not* call restoreContextOnFailure here.  If the user
+   -- is trying to fix up a context that contains errors by removing
+   -- modules, we don't want GHC to silently put them back in again.
    mapM_ rm (starred ++ unstarred)
    setGHCContextFromGHCiState
  where
@@ -1650,13 +1657,13 @@ remModulesFromContext  starred unstarred = do
            , transient_ctx  = filt (transient_ctx st) }
 
 setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
-setContext starred unstarred = do
+setContext starred unstarred = restoreContextOnFailure $ do
   modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
                                 -- delete the transient context
-  addModulesToContext starred unstarred
+  addModulesToContext_ starred unstarred
 
 addImportToContext :: String -> GHCi ()
-addImportToContext str = do
+addImportToContext str = restoreContextOnFailure $ do
   idecl <- GHC.parseImportDecl str
   addII (IIDecl idecl)   -- #5836
   setGHCContextFromGHCiState
@@ -1671,6 +1678,25 @@ addII iidecl = do
                                  (transient_ctx st)
         }
 
+-- Sometimes we can't tell whether an import is valid or not until
+-- we finally call 'GHC.setContext'.  e.g.
+--
+--   import System.IO (foo)
+--
+-- will fail because System.IO does not export foo.  In this case we
+-- don't want to store the import in the context permanently, so we
+-- catch the failure from 'setGHCContextFromGHCiState' and set the
+-- context back to what it was.
+--
+-- See #6007
+--
+restoreContextOnFailure :: GHCi a -> GHCi a
+restoreContextOnFailure do_this = do
+  st <- getGHCiState
+  let rc = remembered_ctx st; tc = transient_ctx st
+  do_this `gonException` (modifyGHCiState $ \st' ->
+     st' { remembered_ctx = rc, transient_ctx = tc })
+
 -- -----------------------------------------------------------------------------
 -- Validate a module that we want to add to the context
 
@@ -1720,12 +1746,11 @@ setGHCContextFromGHCiState = do
       -- the actual exception thrown by checkAdd, using tryBool to
       -- turn it into a Bool.
   iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
-  GHC.setContext (maybeAddPrelude iidecls)
- where
-  maybeAddPrelude :: [InteractiveImport] -> [InteractiveImport]
-  maybeAddPrelude iidecls
-    | any isPreludeImport iidecls = iidecls
-    | otherwise                   = iidecls ++ [implicitPreludeImport]
+  dflags <- GHC.getSessionDynFlags
+  GHC.setContext $
+     if xopt Opt_ImplicitPrelude dflags && not (any isPreludeImport iidecls)
+        then iidecls ++ [implicitPreludeImport]
+        else iidecls
     -- XXX put prel at the end, so that guessCurrentModule doesn't pick it up.
 
 
@@ -1776,13 +1801,21 @@ filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
 -- because e.g. a module might export a name that is only available
 -- qualified within the module itself.
 --
+-- Note that 'import M' does not necessarily subsume 'import M(foo)',
+-- because M might not export foo and we want an error to be produced
+-- in that case.
+--
 iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
 iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
 iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude
   =  unLoc (ideclName d1) == unLoc (ideclName d2)
      && ideclAs d1 == ideclAs d2
      && (not (ideclQualified d1) || ideclQualified d2)
-     && (isNothing (ideclHiding d1) || ideclHiding d1 == ideclHiding d2)
+     && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
+  where
+     _                `hidingSubsumes` Just (False,[]) = True
+     Just (False, xs) `hidingSubsumes` Just (False,ys) = all (`elem` xs) ys
+     h1               `hidingSubsumes` h2              = h1 == h2
 iiSubsumes _ _ = False
 
 
index 037d4e1..2572bab 100644 (file)
@@ -4,6 +4,7 @@ for various bits of the RTS.  They are linked
 in instead of the defaults.
 */
 
+#include "../rts/PosixSource.h"
 #include "Rts.h"
 
 #include "HsFFI.h"
@@ -31,8 +32,8 @@ defaultsHook (void)
 }
 
 void
-StackOverflowHook (unsigned long stack_size)    /* in bytes */
+StackOverflowHook (lnat stack_size)    /* in bytes */
 {
-    fprintf(stderr, "GHC stack-space overflow: current limit is %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
+    fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
 }
 
index c1f4f05..501b9dc 100644 (file)
@@ -143,41 +143,8 @@ void _assertFail(const char *filename, unsigned int linenum)
 #define USED_IF_NOT_THREADS
 #endif
 
-#if SIZEOF_VOID_P == 8
-# if SIZEOF_LONG == 8
-#  define FMT_SizeT "lu"
-# elif SIZEOF_LONG_LONG == 8
-#  define FMT_SizeT "llu"
-# else
-#  error Cannot find format specifier for size_t size type
-# endif
-#elif SIZEOF_VOID_P == 4
-# if SIZEOF_INT == 4
-#  define FMT_SizeT "u"
-# else
-#  error Cannot find format specifier for size_t size type
-# endif
-#else
-# error Cannot handle this word size
-#endif
-
-/*
- * Getting printf formats right for platform-dependent typedefs
- */
-#if SIZEOF_LONG == 8
-#define FMT_Word64 "lu"
-#define FMT_Int64  "ld"
-#else
-#if defined(mingw32_HOST_OS)
-/* mingw doesn't understand %llu/%lld - it treats them as 32-bit
-   rather than 64-bit */
-#define FMT_Word64 "I64u"
-#define FMT_Int64  "I64d"
-#else
-#define FMT_Word64 "llu"
-#define FMT_Int64  "lld"
-#endif
-#endif
+#define FMT_SizeT    "zu"
+#define FMT_HexSizeT "zx"
 
 /* -----------------------------------------------------------------------------
    Time values in the RTS
index 6f2e6de..4042498 100644 (file)
@@ -21,6 +21,7 @@
 #define PROFILING
 #define THREADED_RTS
 
+#include "PosixSource.h"
 #include "Rts.h"
 #include "Stable.h"
 #include "Capability.h"
@@ -199,7 +200,7 @@ main(int argc, char *argv[])
 
     printf("#define BLOCK_SIZE   %u\n", BLOCK_SIZE);
     printf("#define MBLOCK_SIZE   %u\n", MBLOCK_SIZE);
-    printf("#define BLOCKS_PER_MBLOCK  %lu\n", (lnat)BLOCKS_PER_MBLOCK);
+    printf("#define BLOCKS_PER_MBLOCK  %" FMT_SizeT "\n", (lnat)BLOCKS_PER_MBLOCK);
     // could be derived, but better to save doing the calculation twice
 
     printf("\n\n");
index f878dc6..f409205 100644 (file)
@@ -18,9 +18,9 @@ extern char *ghc_rts_opts;
 
 extern void OnExitHook (void);
 extern int  NoRunnableThreadsHook (void);
-extern void StackOverflowHook (unsigned long stack_size);
-extern void OutOfHeapHook (unsigned long request_size, unsigned long heap_size);
-extern void MallocFailHook (unsigned long request_size /* in bytes */, char *msg);
+extern void StackOverflowHook (lnat stack_size);
+extern void OutOfHeapHook (lnat request_size, lnat heap_size);
+extern void MallocFailHook (lnat request_size /* in bytes */, char *msg);
 extern void defaultsHook (void);
 
 #endif /* RTS_HOOKS_H */
index 6f59d1d..d3dabde 100644 (file)
 
 #include <stdarg.h>
 
+#if defined(mingw32_HOST_OS)
+/* On Win64, if we say "printf" then gcc thinks we are going to use
+   MS format specifiers like %I64d rather than %llu */
+#define PRINTF gnu_printf
+#else
+/* However, on OS X, "gnu_printf" isn't recognised */
+#define PRINTF printf
+#endif
+
 /* -----------------------------------------------------------------------------
  * Message generation
  * -------------------------------------------------------------------------- */
@@ -48,7 +57,7 @@ void vbarf(const char *s, va_list ap)
  * errorBelch() invokes (*errorMsgFn)().
  */
 void errorBelch(const char *s, ...)
-   GNUC3_ATTRIBUTE(format (printf, 1, 2));
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
 
 void verrorBelch(const char *s, va_list ap);
 
@@ -62,7 +71,7 @@ void verrorBelch(const char *s, va_list ap);
  * sysErrorBelch() invokes (*sysErrorMsgFn)().
  */
 void sysErrorBelch(const char *s, ...)
-   GNUC3_ATTRIBUTE(format (printf, 1, 2));
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
 
 void vsysErrorBelch(const char *s, va_list ap);
 
@@ -74,7 +83,7 @@ void vsysErrorBelch(const char *s, va_list ap);
  * debugBelch() invokes (*debugMsgFn)().
  */
 void debugBelch(const char *s, ...)
-   GNUC3_ATTRIBUTE(format (printf, 1, 2));
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
 
 void vdebugBelch(const char *s, va_list ap);
 
index 18a3ce0..ff42cda 100644 (file)
 #ifndef RTS_TYPES_H
 #define RTS_TYPES_H
 
-typedef unsigned int  nat;           /* at least 32 bits (like int) */
-typedef unsigned long lnat;          /* at least 32 bits            */
+#include <stddef.h>
+
+typedef unsigned int    nat;           /* at least 32 bits (like int) */
+typedef          size_t lnat;          /* at least 32 bits            */
 
 /* ullong (64|128-bit) type: only include if needed (not ANSI) */
 #if defined(__GNUC__) 
index 4fed346..c93cc31 100644 (file)
@@ -426,6 +426,7 @@ RTS_FUN_DECL(stg_isCurrentThreadBoundzh);
 RTS_FUN_DECL(stg_threadStatuszh);
 
 RTS_FUN_DECL(stg_mkWeakzh);
+RTS_FUN_DECL(stg_mkWeakNoFinalizzerzh);
 RTS_FUN_DECL(stg_mkWeakForeignzh);
 RTS_FUN_DECL(stg_mkWeakForeignEnvzh);
 RTS_FUN_DECL(stg_finalizzeWeakzh);
index e05690a..839c064 100644 (file)
@@ -54,12 +54,18 @@ typedef unsigned char            StgWord8;
 typedef signed   short           StgInt16;
 typedef unsigned short           StgWord16;
 
-#if SIZEOF_LONG == 4
-typedef signed   long            StgInt32;
-typedef unsigned long            StgWord32;
-#elif SIZEOF_INT == 4
+#if SIZEOF_INT == 4
 typedef signed   int             StgInt32;
 typedef unsigned int             StgWord32;
+#define FMT_Word32    "u"
+#define FMT_HexWord32 "x"
+#define FMT_Int32     "d"
+#elif SIZEOF_LONG == 4
+typedef signed   long            StgInt32;
+typedef unsigned long            StgWord32;
+#define FMT_Word32    "lu"
+#define FMT_HexWord32 "lx"
+#define FMT_Int32     "ld"
 #else
 #error GHC untested on this architecture: sizeof(int) != 4
 #endif
@@ -67,12 +73,15 @@ typedef unsigned int             StgWord32;
 #if SIZEOF_LONG == 8
 typedef signed   long          StgInt64;
 typedef unsigned long          StgWord64;
-#elif defined(__MSVC__)
-typedef __int64                StgInt64;
-typedef unsigned __int64       StgWord64;
+#define FMT_Word64    "lu"
+#define FMT_HexWord64 "lx"
+#define FMT_Int64     "ld"
 #elif SIZEOF_LONG_LONG == 8
 typedef signed long long int   StgInt64;
 typedef unsigned long long int StgWord64;
+#define FMT_Word64    "llu"
+#define FMT_HexWord64 "llx"
+#define FMT_Int64     "lld"
 #else
 #error cannot find a way to define StgInt64
 #endif
@@ -93,12 +102,18 @@ typedef StgInt64           StgInt;
 typedef StgWord64          StgWord;
 typedef StgInt32           StgHalfInt;
 typedef StgWord32          StgHalfWord;
+#define FMT_Word     FMT_Word64
+#define FMT_HexWord  FMT_HexWord64
+#define FMT_Int      FMT_Int64
 #else
 #if SIZEOF_VOID_P == 4
 typedef StgInt32           StgInt; 
 typedef StgWord32          StgWord;
 typedef StgInt16           StgHalfInt;
 typedef StgWord16          StgHalfWord;
+#define FMT_Word     FMT_Word32
+#define FMT_HexWord  FMT_HexWord32
+#define FMT_Int      FMT_Int32
 #else
 #error GHC untested on this architecture: sizeof(void *) != 4 or 8
 #endif
index 119dce1..fa5add5 100644 (file)
@@ -1,20 +1,22 @@
 # DO NOT EDIT!  Instead, create a file mk/validate.mk, whose settings will
 # override these.  See also mk/custom-settings.mk.
 
-WERROR          = -Werror
+WERROR              = -Werror
+SRC_CC_WARNING_OPTS =
+SRC_HC_WARNING_OPTS =
 
 HADDOCK_DOCS    = YES
 
-SRC_CC_OPTS     += -Wall $(WERROR)
 # Debian doesn't turn -Werror=unused-but-set-variable on by default, so
 # we turn it on explicitly for consistency with other users
 ifeq "$(GccLT46)" "NO"
-SRC_CC_OPTS     += -Werror=unused-but-set-variable
+SRC_CC_WARNING_OPTS += -Werror=unused-but-set-variable
 # gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined
-SRC_CC_OPTS     += -Wno-error=inline
+SRC_CC_WARNING_OPTS += -Wno-error=inline
 endif
 
-SRC_HC_OPTS     += -Wall $(WERROR) -H64m -O0
+SRC_CC_OPTS     += $(WERROR) -Wall
+SRC_HC_OPTS     += $(WERROR) -Wall -H64m -O0
 
 GhcStage1HcOpts += -O -fwarn-tabs
 
index 7b1a110..b3b7629 100644 (file)
@@ -419,7 +419,7 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task)
     ASSERT(task->cap == cap);
     debugTrace(DEBUG_sched, "passing capability %d to %s %p",
                cap->no, task->incall->tso ? "bound task" : "worker",
-               (void *)task->id);
+               (void *)(size_t)task->id);
     ACQUIRE_LOCK(&task->lock);
     if (task->wakeup == rtsFalse) {
         task->wakeup = rtsTrue;
@@ -887,7 +887,7 @@ shutdownCapability (Capability *cap USED_IF_THREADS,
             for (t = cap->spare_workers; t != NULL; t = t->next) {
                 if (!osThreadIsAlive(t->id)) {
                     debugTrace(DEBUG_sched, 
-                               "worker thread %p has died unexpectedly", (void *)t->id);
+                               "worker thread %p has died unexpectedly", (void *)(size_t)t->id);
                     cap->n_spare_workers--;
                     if (!prev) {
                         cap->spare_workers = t->next;
index d043e1d..033af11 100644 (file)
@@ -75,12 +75,12 @@ disInstr ( StgBCO *bco, int pc )
                          instrs[pc], (signed int)instrs[pc+1]);
          pc += 2; break;
       case bci_CCALL:
-         debugBelch("CCALL    marshaller at 0x%lx\n", 
+         debugBelch("CCALL    marshaller at 0x%" FMT_Word "\n", 
                          literals[instrs[pc]] );
          pc += 1; break;
      case bci_STKCHECK:  {
          StgWord stk_words_reqd = BCO_GET_LARGE_ARG + 1;
-         debugBelch("STKCHECK %lu\n", (lnat)stk_words_reqd );
+         debugBelch("STKCHECK %" FMT_SizeT "\n", (lnat)stk_words_reqd );
          break;
      }
       case bci_PUSH_L: 
@@ -130,7 +130,7 @@ disInstr ( StgBCO *bco, int pc )
       case bci_PUSH_UBX:
          debugBelch("PUSH_UBX ");
          for (i = 0; i < instrs[pc+1]; i++) 
-            debugBelch("0x%lx ", literals[i + instrs[pc]] );
+            debugBelch("0x%" FMT_Word " ", literals[i + instrs[pc]] );
          debugBelch("\n");
          pc += 2; break;
       case bci_PUSH_APPLY_N:
@@ -199,29 +199,29 @@ disInstr ( StgBCO *bco, int pc )
       case bci_TESTLT_I: {
           unsigned int discr  = BCO_NEXT;
           int failto = BCO_GET_LARGE_ARG;
-          debugBelch("TESTLT_I  %ld, fail to %d\n", literals[discr], failto);
+          debugBelch("TESTLT_I  %" FMT_Int ", fail to %d\n", literals[discr], failto);
           break;
       }
       case bci_TESTEQ_I:
-         debugBelch("TESTEQ_I  %ld, fail to %d\n", literals[instrs[pc]],
+         debugBelch("TESTEQ_I  %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
                                                       instrs[pc+1]);
          pc += 2; break;
 
       case bci_TESTLT_F:
-         debugBelch("TESTLT_F  %ld, fail to %d\n", literals[instrs[pc]],
+         debugBelch("TESTLT_F  %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
                                                       instrs[pc+1]);
          pc += 2; break;
       case bci_TESTEQ_F:
-         debugBelch("TESTEQ_F  %ld, fail to %d\n", literals[instrs[pc]],
+         debugBelch("TESTEQ_F  %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
                                                       instrs[pc+1]);
          pc += 2; break;
 
       case bci_TESTLT_D:
-         debugBelch("TESTLT_D  %ld, fail to %d\n", literals[instrs[pc]],
+         debugBelch("TESTLT_D  %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
                                                       instrs[pc+1]);
          pc += 2; break;
       case bci_TESTEQ_D:
-         debugBelch("TESTEQ_D  %ld, fail to %d\n", literals[instrs[pc]],
+         debugBelch("TESTEQ_D  %" FMT_Int ", fail to %d\n", literals[instrs[pc]],
                                                       instrs[pc+1]);
          pc += 2; break;
 
index c983403..4fb8e62 100644 (file)
@@ -294,6 +294,7 @@ typedef struct _RtsSymbolVal {
 } RtsSymbolVal;
 
 #define Maybe_Stable_Names      SymI_HasProto(stg_mkWeakzh)                     \
+                                SymI_HasProto(stg_mkWeakNoFinalizzerzh)         \
                                 SymI_HasProto(stg_mkWeakForeignEnvzh)           \
                                 SymI_HasProto(stg_makeStableNamezh)             \
                                 SymI_HasProto(stg_finalizzeWeakzh)
@@ -2428,6 +2429,7 @@ addProddableBlock ( ObjectCode* oc, void* start, int size )
    oc->proddables = pb;
 }
 
+#if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
 static void
 checkProddableBlock (ObjectCode *oc, void *addr )
 {
@@ -2444,6 +2446,7 @@ checkProddableBlock (ObjectCode *oc, void *addr )
    }
    barf("checkProddableBlock: invalid fixup in runtime linker");
 }
+#endif
 
 /* -----------------------------------------------------------------------------
  * Section management.
@@ -2459,8 +2462,8 @@ addSection ( ObjectCode* oc, SectionKind kind,
    s->next      = oc->sections;
    oc->sections = s;
 
-   IF_DEBUG(linker, debugBelch("addSection: %p-%p (size %ld), kind %d\n",
-                               start, ((char*)end)-1, (long)end - (long)start + 1, kind ));
+   IF_DEBUG(linker, debugBelch("addSection: %p-%p (size %lld), kind %d\n",
+                               start, ((char*)end)-1, ((long long)(size_t)end) - ((long long)(size_t)start) + 1, kind ));
 }
 
 
@@ -2473,6 +2476,7 @@ addSection ( ObjectCode* oc, SectionKind kind,
  */
 
 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(arm_HOST_ARCH)
+#if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
 
 /*
   ocAllocateSymbolExtras
@@ -2551,6 +2555,7 @@ static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first )
   return 1;
 }
 
+#endif
 #endif // defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) || defined(arm_HOST_ARCH)
 
 #if defined(arm_HOST_ARCH)
@@ -2567,6 +2572,7 @@ ocFlushInstructionCache( ObjectCode *oc )
 #endif
 
 #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
+#if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
 
 static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
                                      unsigned long symbolNumber,
@@ -2604,6 +2610,7 @@ static SymbolExtra* makeSymbolExtra( ObjectCode* oc,
   return extra;
 }
 
+#endif
 #endif // defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)
 
 #ifdef arm_HOST_ARCH
@@ -2887,6 +2894,7 @@ printName ( UChar* name, UChar* strtab )
 }
 
 
+#if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
 static void
 copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
 {
@@ -2905,6 +2913,7 @@ copyName ( UChar* name, UChar* strtab, UChar* dst, int dstSize )
       dst[i] = 0;
    }
 }
+#endif
 
 
 static UChar *
@@ -2960,6 +2969,7 @@ cstring_from_section_name (UChar* name, UChar* strtab)
     }
 }
 
+#if !defined(x86_64_HOST_ARCH) || !defined(mingw32_HOST_OS)
 /* Just compares the short names (first 8 chars) */
 static COFF_section *
 findPEi386SectionCalled ( ObjectCode* oc,  UChar* name )
@@ -2988,7 +2998,7 @@ findPEi386SectionCalled ( ObjectCode* oc,  UChar* name )
 
    return NULL;
 }
-
+#endif
 
 static void
 zapTrailingAtSign ( UChar* sym )
@@ -3099,9 +3109,9 @@ ocVerifyImage_PEi386 ( ObjectCode* oc )
    IF_DEBUG(linker, i=1);
    if (i == 0) return 1;
 
-   debugBelch( "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
-   debugBelch( "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
-   debugBelch( "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
+   debugBelch( "sectab offset = %" FMT_Int "\n", ((UChar*)sectab) - ((UChar*)hdr) );
+   debugBelch( "symtab offset = %" FMT_Int "\n", ((UChar*)symtab) - ((UChar*)hdr) );
+   debugBelch( "strtab offset = %" FMT_Int "\n", ((UChar*)strtab) - ((UChar*)hdr) );
 
    debugBelch("\n" );
    debugBelch( "Machine:           0x%x\n", (UInt32)(hdr->Machine) );
@@ -3451,8 +3461,13 @@ ocGetNames_PEi386 ( ObjectCode* oc )
 
 
 static int
-ocResolve_PEi386 ( ObjectCode* oc )
+ocResolve_PEi386 ( ObjectCode* oc
+#if !defined(i386_HOST_ARCH)
+                                  STG_UNUSED
+#endif
+                                             )
 {
+#if defined(i386_HOST_ARCH)
    COFF_header*  hdr;
    COFF_section* sectab;
    COFF_symbol*  symtab;
@@ -3535,7 +3550,6 @@ ocResolve_PEi386 ( ObjectCode* oc )
         j = 0;
       }
 
-
       for (; j < noRelocs; j++) {
          COFF_symbol* sym;
          COFF_reloc* reltab_j
@@ -3627,6 +3641,9 @@ ocResolve_PEi386 ( ObjectCode* oc )
 
    IF_DEBUG(linker, debugBelch("completed %" PATH_FMT, oc->fileName));
    return 1;
+#else
+   barf("ocResolve_PEi386: Not supported on this arch");
+#endif
 }
 
 #endif /* defined(OBJFORMAT_PEi386) */
index aaedabb..93ef23a 100644 (file)
@@ -384,14 +384,10 @@ stg_mkWeakzh
 {
   /* R1 = key
      R2 = value
-     R3 = finalizer (or NULL)
+     R3 = finalizer (or stg_NO_FINALIZER_closure)
   */
   W_ w;
 
-  if (R3 == NULL) {
-    R3 = stg_NO_FINALIZER_closure;
-  }
-
   ALLOC_PRIM( SIZEOF_StgWeak, R1_PTR & R2_PTR & R3_PTR, stg_mkWeakzh );
 
   w = Hp - SIZEOF_StgWeak + WDS(1);
@@ -416,6 +412,16 @@ stg_mkWeakzh
   RET_P(w);
 }
 
+stg_mkWeakNoFinalizzerzh
+{
+  /* R1 = key
+     R2 = value
+   */
+  R3 = stg_NO_FINALIZER_closure;
+
+  jump stg_mkWeakzh;
+}
+
 stg_mkWeakForeignEnvzh
 {
   /* R1 = key
index 688ed7b..a7ce367 100644 (file)
@@ -147,7 +147,7 @@ printClosure( StgClosure *obj )
     case FUN_1_0: case FUN_0_1: 
     case FUN_1_1: case FUN_0_2: case FUN_2_0:
     case FUN_STATIC:
-       debugBelch("FUN/%d(",itbl_to_fun_itbl(info)->f.arity);
+       debugBelch("FUN/%d(",(int)itbl_to_fun_itbl(info)->f.arity);
        printPtr((StgPtr)obj->header.info);
 #ifdef PROFILING
        debugBelch(", %s", obj->header.prof.ccs->cc->label);
@@ -199,7 +199,7 @@ printClosure( StgClosure *obj )
         {
            StgPAP* pap = (StgPAP*)obj;
             StgWord i;
-            debugBelch("PAP/%d(",pap->arity); 
+            debugBelch("PAP/%d(",(int)pap->arity); 
            printPtr((StgPtr)pap->fun);
             for (i = 0; i < pap->n_args; ++i) {
                 debugBelch(", ");
@@ -299,21 +299,21 @@ printClosure( StgClosure *obj )
             StgWord i;
             debugBelch("ARR_WORDS(\"");
            for (i=0; i<arr_words_words((StgArrWords *)obj); i++)
-             debugBelch("%lu", (lnat)((StgArrWords *)obj)->payload[i]);
+             debugBelch("%" FMT_SizeT, (lnat)((StgArrWords *)obj)->payload[i]);
             debugBelch("\")\n");
             break;
         }
 
     case MUT_ARR_PTRS_CLEAN:
-       debugBelch("MUT_ARR_PTRS_CLEAN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
+       debugBelch("MUT_ARR_PTRS_CLEAN(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
        break;
 
     case MUT_ARR_PTRS_DIRTY:
-       debugBelch("MUT_ARR_PTRS_DIRTY(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
+       debugBelch("MUT_ARR_PTRS_DIRTY(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
        break;
 
     case MUT_ARR_PTRS_FROZEN:
-       debugBelch("MUT_ARR_PTRS_FROZEN(size=%lu)\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
+       debugBelch("MUT_ARR_PTRS_FROZEN(size=%" FMT_SizeT ")\n", (lnat)((StgMutArrPtrs *)obj)->ptrs);
        break;
 
     case MVAR_CLEAN:
@@ -366,7 +366,7 @@ printClosure( StgClosure *obj )
     default:
             //barf("printClosure %d",get_itbl(obj)->type);
             debugBelch("*** printClosure: unknown type %d ****\n",
-                    get_itbl(obj)->type );
+                    (int)get_itbl(obj)->type );
             barf("printClosure %d",get_itbl(obj)->type);
             return;
     }
@@ -426,7 +426,7 @@ printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size )
            printPtr((P_)payload[i]);
            debugBelch("\n");
        } else {
-           debugBelch("Word# %lu\n", (lnat)payload[i]);
+           debugBelch("Word# %" FMT_SizeT "\n", (lnat)payload[i]);
        }
     }
 }
@@ -442,12 +442,12 @@ printLargeBitmap( StgPtr spBottom, StgPtr payload, StgLargeBitmap* large_bitmap,
        StgWord bitmap = large_bitmap->bitmap[bmp];
        j = 0;
        for(; i < size && j < BITS_IN(W_); j++, i++, bitmap >>= 1 ) {
-           debugBelch("   stk[%lu] (%p) = ", (lnat)(spBottom-(payload+i)), payload+i);
+           debugBelch("   stk[%" FMT_SizeT "] (%p) = ", (lnat)(spBottom-(payload+i)), payload+i);
            if ((bitmap & 1) == 0) {
                printPtr((P_)payload[i]);
                debugBelch("\n");
            } else {
-               debugBelch("Word# %lu\n", (lnat)payload[i]);
+               debugBelch("Word# %" FMT_SizeT "\n", (lnat)payload[i]);
            }
        }
     }
@@ -532,7 +532,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
 
            ret_fun = (StgRetFun *)sp;
            fun_info = get_fun_itbl(ret_fun->fun);
-           debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, fun_info->f.fun_type);
+           debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, (int)fun_info->f.fun_type);
            switch (fun_info->f.fun_type) {
            case ARG_GEN:
                printSmallBitmap(spBottom, sp+2,
@@ -554,7 +554,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
        }
           
        default:
-           debugBelch("unknown object %d\n", info->type);
+           debugBelch("unknown object %d\n", (int)info->type);
            barf("printStackChunk");
        }
     }
index bd2f140..c7048a5 100644 (file)
@@ -821,7 +821,7 @@ dumpCensus( Census *census )
        }
 #endif
 
-       fprintf(hp_file, "\t%lu\n", (unsigned long)count * sizeof(W_));
+       fprintf(hp_file, "\t%" FMT_SizeT "\n", (lnat)count * sizeof(W_));
     }
 
     printSample(rtsFalse, census->time);
index 320a1b2..4e156e6 100644 (file)
@@ -1542,7 +1542,7 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max)
     if (m < 0 || val < min || val > max) {
         // printf doesn't like 64-bit format specs on Windows
         // apparently, so fall back to unsigned long.
-        errorBelch("error in RTS option %s: size outside allowed range (%lu - %lu)", flag, (lnat)min, (lnat)max);
+        errorBelch("error in RTS option %s: size outside allowed range (%" FMT_SizeT " - %" FMT_SizeT ")", flag, (lnat)min, (lnat)max);
         stg_exit(EXIT_FAILURE);
     }
 
index 4b9f6ba..307a691 100644 (file)
@@ -141,7 +141,14 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     defaultsHook();
 
     /* Parse the flags, separating the RTS flags from the programs args */
-    if (argc != NULL && argv != NULL) {
+    if (argc == NULL || argv == NULL) {
+        // Use a default for argc & argv if either is not supplied
+        int my_argc = 1;
+        char *my_argv[] = { "<unknown>", NULL };
+        setFullProgArgv(my_argc,my_argv);
+        setupRtsFlags(&my_argc, my_argv,
+                      rts_config.rts_opts_enabled, rts_config.rts_opts);
+    } else {
         setFullProgArgv(*argc,*argv);
         setupRtsFlags(argc, *argv,
                       rts_config.rts_opts_enabled, rts_config.rts_opts);
index cebb753..5605810 100644 (file)
@@ -383,10 +383,10 @@ stat_endGC (Capability *cap, gc_thread *gct,
         if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) {
            nat faults = getPageFaults();
            
-           statsPrintf("%9ld %9ld %9ld",
+           statsPrintf("%9" FMT_SizeT " %9" FMT_SizeT " %9" FMT_SizeT,
                    alloc*sizeof(W_), copied*sizeof(W_), 
                        live*sizeof(W_));
-            statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld  (Gen: %2d)\n",
+            statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4" FMT_SizeT " %4" FMT_SizeT "  (Gen: %2d)\n",
                     TimeToSecondsDbl(gc_cpu),
                    TimeToSecondsDbl(gc_elapsed),
                    TimeToSecondsDbl(cpu),
@@ -627,7 +627,7 @@ stat_exit(int alloc)
        if (tot_elapsed == 0.0) tot_elapsed = 1;
        
        if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) {
-           statsPrintf("%9ld %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", "");
+           statsPrintf("%9" FMT_SizeT " %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", "");
            statsPrintf(" %5.2f %5.2f\n\n", 0.0, 0.0);
        }
 
@@ -666,16 +666,16 @@ stat_exit(int alloc)
             if ( residency_samples > 0 ) {
                showStgWord64(max_residency*sizeof(W_), 
                                     temp, rtsTrue/*commas*/);
-               statsPrintf("%16s bytes maximum residency (%ld sample(s))\n",
+               statsPrintf("%16s bytes maximum residency (%" FMT_SizeT " sample(s))\n",
                        temp, residency_samples);
            }
 
            showStgWord64(max_slop*sizeof(W_), temp, rtsTrue/*commas*/);
            statsPrintf("%16s bytes maximum slop\n", temp);
 
-           statsPrintf("%16ld MB total memory in use (%ld MB lost due to fragmentation)\n\n", 
+           statsPrintf("%16" FMT_SizeT " MB total memory in use (%" FMT_SizeT " MB lost due to fragmentation)\n\n", 
                         peak_mblocks_allocated * MBLOCK_SIZE_W / (1024 * 1024 / sizeof(W_)),
-                        (peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_)));
+                        (lnat)(peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_)));
 
            /* Print garbage collections in each gen */
             statsPrintf("                                    Tot time (elapsed)  Avg pause  Max pause\n");
@@ -721,7 +721,7 @@ stat_exit(int alloc)
                     sparks.fizzled   += capabilities[i].spark_stats.fizzled;
                 }
 
-                statsPrintf("  SPARKS: %ld (%ld converted, %ld overflowed, %ld dud, %ld GC'd, %ld fizzled)\n\n",
+                statsPrintf("  SPARKS: %" FMT_Word " (%" FMT_Word " converted, %" FMT_Word " overflowed, %" FMT_Word " dud, %" FMT_Word " GC'd, %" FMT_Word " fizzled)\n\n",
                             sparks.created + sparks.dud + sparks.overflowed,
                             sparks.converted, sparks.overflowed, sparks.dud,
                             sparks.gcd, sparks.fizzled);
@@ -896,17 +896,18 @@ statDescribeGens(void)
           gen_blocks += gcThreadLiveBlocks(i,g);
       }
 
-      debugBelch("%5d %7ld %9d", g, (lnat)gen->max_blocks, mut);
+      debugBelch("%5d %7" FMT_SizeT " %9d", g, (lnat)gen->max_blocks, mut);
 
       gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live;
 
-      debugBelch("%8ld %8d %8ld %8ld\n", gen_blocks, lge,
+      debugBelch("%8" FMT_SizeT " %8d %8" FMT_SizeT " %8" FMT_SizeT "\n", gen_blocks, lge,
                  gen_live*sizeof(W_), gen_slop*sizeof(W_));
       tot_live += gen_live;
       tot_slop += gen_slop;
   }
   debugBelch("----------------------------------------------------------\n");
-  debugBelch("%41s%8ld %8ld\n","",tot_live*sizeof(W_),tot_slop*sizeof(W_));
+  debugBelch("%41s%8" FMT_SizeT " %8" FMT_SizeT "\n",
+             "",tot_live*sizeof(W_),tot_slop*sizeof(W_));
   debugBelch("----------------------------------------------------------\n");
   debugBelch("\n");
 }
index baabd26..d74cf29 100644 (file)
 
 #include "BeginPrivate.h"
 
+#if defined(mingw32_HOST_OS)
+/* On Win64, if we say "printf" then gcc thinks we are going to use
+   MS format specifiers like %I64d rather than %llu */
+#define PRINTF gnu_printf
+#else
+/* However, on OS X, "gnu_printf" isn't recognised */
+#define PRINTF printf
+#endif
+
 struct gc_thread_;
 
 void      stat_startInit(void);
@@ -64,7 +73,7 @@ Time stat_getElapsedTime(void);
 
 /* Only exported for Papi.c */
 void statsPrintf( char *s, ... ) 
-    GNUC3_ATTRIBUTE(format (printf, 1, 2));
+    GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
 
 #include "EndPrivate.h"
 
index f4a37bf..125000b 100644 (file)
@@ -320,7 +320,7 @@ discardTasksExcept (Task *keep)
     for (task = all_tasks; task != NULL; task=next) {
         next = task->all_next;
         if (task != keep) {
-            debugTrace(DEBUG_sched, "discarding task %ld", (long)TASK_ID(task));
+            debugTrace(DEBUG_sched, "discarding task %" FMT_SizeT "", (size_t)TASK_ID(task));
             freeTask(task);
         }
     }
@@ -393,7 +393,7 @@ workerTaskStop (Task *task)
 static void *taskId(Task *task)
 {
 #ifdef THREADED_RTS
-    return (void *)task->id;
+    return (void *)(size_t)task->id;
 #else
     return (void *)task;
 #endif
index 140a705..af33805 100644 (file)
@@ -217,7 +217,7 @@ PrintTickyInfo(void)
   fprintf(tf,"%7ld (%5.1f%%) normal indirections\n",
        tot_ind_enters,
        PC(INTAVG(tot_ind_enters,tot_enters)));
-  fprintf(tf,"%7ld (%5.1f%%) permanent indirections\n",
+  fprintf(tf,"%7" FMT_Int " (%5.1f%%) permanent indirections\n",
        ENT_PERM_IND_ctr,
        PC(INTAVG(ENT_PERM_IND_ctr,tot_enters)));
 
@@ -228,13 +228,13 @@ PrintTickyInfo(void)
          tot_tail_calls, tot_known_calls,
          PC(INTAVG(tot_known_calls,tot_tail_calls)));
 
-  fprintf(tf, "\nSLOW APPLICATIONS: %ld evaluated, %ld unevaluated\n",
+  fprintf(tf, "\nSLOW APPLICATIONS: %" FMT_Int " evaluated, %" FMT_Int " unevaluated\n",
          SLOW_CALL_ctr, SLOW_CALL_UNEVALD_ctr);
   fprintf(tf, "\n");
   fprintf(tf, "         Too few args   Correct args   Too many args\n");
-  fprintf(tf, "   FUN     %8ld       %8ld        %8ld\n", 
+  fprintf(tf, "   FUN     %8" FMT_Int "       %8" FMT_Int "        %8" FMT_Int "\n", 
          SLOW_CALL_FUN_TOO_FEW_ctr, SLOW_CALL_FUN_CORRECT_ctr, SLOW_CALL_FUN_TOO_MANY_ctr);
-  fprintf(tf, "   PAP     %8ld       %8ld        %8ld\n", 
+  fprintf(tf, "   PAP     %8" FMT_Int "       %8" FMT_Int "        %8" FMT_Int "\n", 
          SLOW_CALL_PAP_TOO_FEW_ctr, SLOW_CALL_PAP_CORRECT_ctr, SLOW_CALL_PAP_TOO_MANY_ctr);
   fprintf(tf, "\n");
 
@@ -261,27 +261,27 @@ PrintTickyInfo(void)
   fprintf(tf, "\n");
   */
 
-  fprintf(tf,"\nUPDATE FRAMES: %ld (%ld omitted from thunks)",
+  fprintf(tf,"\nUPDATE FRAMES: %" FMT_Int " (%" FMT_Int " omitted from thunks)",
        UPDF_PUSHED_ctr,
        UPDF_OMITTED_ctr);
 
-  fprintf(tf,"\nCATCH FRAMES:  %ld", CATCHF_PUSHED_ctr);
+  fprintf(tf,"\nCATCH FRAMES:  %" FMT_Int "", CATCHF_PUSHED_ctr);
 
   if (UPDF_RCC_PUSHED_ctr != 0)
-     fprintf(tf,"%7ld restore cost centre frames (%ld omitted)\n",
+     fprintf(tf,"%7" FMT_Int " restore cost centre frames (%" FMT_Int " omitted)\n",
        UPDF_RCC_PUSHED_ctr,
        UPDF_RCC_OMITTED_ctr);
 
   fprintf(tf,"\nUPDATES: %ld\n", tot_updates);
-  fprintf(tf,"%7ld (%5.1f%%) data values\n\t\t  [%ld in place, %ld allocated new space]\n",
+  fprintf(tf,"%7ld (%5.1f%%) data values\n\t\t  [%" FMT_Int " in place, %" FMT_Int " allocated new space]\n",
        con_updates,
        PC(INTAVG(con_updates,tot_updates)),
        UPD_CON_IN_PLACE_ctr, UPD_CON_IN_NEW_ctr);
-  fprintf(tf,"%7ld (%5.1f%%) partial applications\n\t\t  [%ld in place, %ld allocated new space]\n",
+  fprintf(tf,"%7ld (%5.1f%%) partial applications\n\t\t  [%" FMT_Int " in place, %" FMT_Int " allocated new space]\n",
        pap_updates,
        PC(INTAVG(pap_updates,tot_updates)),
        UPD_PAP_IN_PLACE_ctr, UPD_PAP_IN_NEW_ctr);
-  fprintf(tf,"%7ld (%5.1f%%) updates by squeezing\n",
+  fprintf(tf,"%7" FMT_Int " (%5.1f%%) updates by squeezing\n",
        UPD_SQUEEZED_ctr,
        PC(INTAVG(UPD_SQUEEZED_ctr, tot_updates)));
 
@@ -317,10 +317,10 @@ PrintTickyInfo(void)
   */
 
 #define PR_CTR(ctr) \
-  do { fprintf(tf,"%7ld " #ctr "\n", ctr); } while(0)
+  do { fprintf(tf,"%7" FMT_Int " " #ctr "\n", ctr); } while(0)
 /* COND_PR_CTR takes a boolean; if false then msg is the printname rather than ctr */
 #define COND_PR_CTR(ctr,b,msg) \
-    if (b) { fprintf(tf,"%7ld " #ctr "\n", ctr); } else { fprintf(tf,"%7ld " msg "\n", ctr); }
+    if (b) { fprintf(tf,"%7" FMT_Int " " #ctr "\n", ctr); } else { fprintf(tf,"%7" FMT_Int " " msg "\n", ctr); }
 #define PR_HST(hst,i) \
   do { fprintf(tf,"%7ld " #hst "_" #i "\n", hst[i]); } while(0)
 
@@ -582,7 +582,7 @@ printRegisteredCounterInfo (FILE *tf)
     /* Function name at the end so it doesn't mess up the tabulation */
 
     for (p = ticky_entry_ctrs; p != NULL; p = p->link) {
-       fprintf(tf, "%11ld%11ld %6lu%6lu    %-11s%-30s",
+       fprintf(tf, "%11" FMT_Int "%11" FMT_Int " %6lu%6lu    %-11s%-30s",
                p->entry_count,
                p->allocs,
                (unsigned long)p->arity,
index e5a4beb..9fa8eb1 100644 (file)
@@ -203,37 +203,37 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag,
     tracePreface();
     switch (tag) {
     case EVENT_CREATE_THREAD:   // (cap, thread)
-        debugBelch("cap %d: created thread %lu\n", 
+        debugBelch("cap %d: created thread %" FMT_SizeT "\n", 
                    cap->no, (lnat)tso->id);
         break;
     case EVENT_RUN_THREAD:      //  (cap, thread)
-        debugBelch("cap %d: running thread %lu (%s)\n", 
+        debugBelch("cap %d: running thread %" FMT_SizeT " (%s)\n", 
                    cap->no, (lnat)tso->id, what_next_strs[tso->what_next]);
         break;
     case EVENT_THREAD_RUNNABLE: // (cap, thread)
-        debugBelch("cap %d: thread %lu appended to run queue\n", 
+        debugBelch("cap %d: thread %" FMT_SizeT " appended to run queue\n", 
                    cap->no, (lnat)tso->id);
         break;
     case EVENT_MIGRATE_THREAD:  // (cap, thread, new_cap)
-        debugBelch("cap %d: thread %lu migrating to cap %d\n", 
+        debugBelch("cap %d: thread %" FMT_SizeT " migrating to cap %d\n", 
                    cap->no, (lnat)tso->id, (int)info1);
         break;
     case EVENT_THREAD_WAKEUP:   // (cap, thread, info1_cap)
-        debugBelch("cap %d: waking up thread %lu on cap %d\n", 
+        debugBelch("cap %d: waking up thread %" FMT_SizeT " on cap %d\n", 
                    cap->no, (lnat)tso->id, (int)info1);
         break;
         
     case EVENT_STOP_THREAD:     // (cap, thread, status)
         if (info1 == 6 + BlockedOnBlackHole) {
-            debugBelch("cap %d: thread %lu stopped (blocked on black hole owned by thread %lu)\n",
+            debugBelch("cap %d: thread %" FMT_SizeT " stopped (blocked on black hole owned by thread %lu)\n",
                        cap->no, (lnat)tso->id, (long)info2);
         } else {
-            debugBelch("cap %d: thread %lu stopped (%s)\n",
+            debugBelch("cap %d: thread %" FMT_SizeT " stopped (%s)\n",
                        cap->no, (lnat)tso->id, thread_stop_reasons[info1]);
         }
         break;
     default:
-        debugBelch("cap %d: thread %lu: event %d\n\n", 
+        debugBelch("cap %d: thread %" FMT_SizeT ": event %d\n\n", 
                    cap->no, (lnat)tso->id, tag);
         break;
     }
@@ -423,17 +423,17 @@ void traceCapsetEvent (EventTypeNum tag,
         tracePreface();
         switch (tag) {
         case EVENT_CAPSET_CREATE:   // (capset, capset_type)
-            debugBelch("created capset %lu of type %d\n", (lnat)capset, (int)info);
+            debugBelch("created capset %" FMT_SizeT " of type %d\n", (lnat)capset, (int)info);
             break;
         case EVENT_CAPSET_DELETE:   // (capset)
-            debugBelch("deleted capset %lu\n", (lnat)capset);
+            debugBelch("deleted capset %" FMT_SizeT "\n", (lnat)capset);
             break;
         case EVENT_CAPSET_ASSIGN_CAP:  // (capset, capno)
-            debugBelch("assigned cap %lu to capset %lu\n",
+            debugBelch("assigned cap %" FMT_SizeT " to capset %" FMT_SizeT "\n",
                        (lnat)info, (lnat)capset);
             break;
         case EVENT_CAPSET_REMOVE_CAP:  // (capset, capno)
-            debugBelch("removed cap %lu from capset %lu\n",
+            debugBelch("removed cap %" FMT_SizeT " from capset %" FMT_SizeT "\n",
                        (lnat)info, (lnat)capset);
             break;
         }
@@ -670,7 +670,7 @@ void traceThreadLabel_(Capability *cap,
     if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
         ACQUIRE_LOCK(&trace_utx);
         tracePreface();
-        debugBelch("cap %d: thread %lu has label %s\n",
+        debugBelch("cap %d: thread %" FMT_SizeT " has label %s\n",
                    cap->no, (lnat)tso->id, label);
         RELEASE_LOCK(&trace_utx);
     } else
index a310377..66b589e 100644 (file)
@@ -237,7 +237,10 @@ initEventLogging(void)
         // Forked process, eventlog already started by the parent
         // before fork
         event_log_pid = getpid();
-        sprintf(event_log_filename, "%s.%d.eventlog", prog, event_log_pid);
+        // We don't have a FMT* symbol for pid_t, so we go via Word64
+        // to be sure of not losing range. It would be nicer to have a
+        // FMT* symbol or similar, though.
+        sprintf(event_log_filename, "%s.%" FMT_Word64 ".eventlog", prog, (StgWord64)event_log_pid);
     }
     stgFree(prog);
 
index d1b0814..b8ee56a 100644 (file)
@@ -106,7 +106,7 @@ void postThreadLabel(Capability    *cap,
 void postHeapEvent (Capability    *cap,
                     EventTypeNum   tag,
                     EventCapsetID  heap_capset,
-                    StgWord        info1);
+                    lnat           info1);
 
 void postEventHeapInfo (EventCapsetID heap_capset,
                         nat           gens,
index 41c0d2a..e298c2e 100644 (file)
@@ -12,6 +12,6 @@
 void
 MallocFailHook (lnat request_size /* in bytes */, char *msg)
 {
-    fprintf(stderr, "malloc: failed on request for %lu bytes; message: %s\n", request_size, msg);
+    fprintf(stderr, "malloc: failed on request for %" FMT_SizeT " bytes; message: %s\n", request_size, msg);
 }
 
index 30c492d..5ed5ed9 100644 (file)
@@ -15,7 +15,7 @@ OutOfHeapHook (lnat request_size, lnat heap_size) /* both sizes in bytes */
 
   (void)request_size;   /* keep gcc -Wall happy */
   if (heap_size > 0) {
-      errorBelch("Heap exhausted;\nCurrent maximum heap size is %lu bytes (%lu MB);\nuse `+RTS -M<size>' to increase it.",
+      errorBelch("Heap exhausted;\nCurrent maximum heap size is %" FMT_SizeT " bytes (%" FMT_SizeT " MB);\nuse `+RTS -M<size>' to increase it.",
           heap_size, heap_size / (1024*1024));
   } else {
       errorBelch("out of memory");
index 4313702..fe8a059 100644 (file)
@@ -12,6 +12,6 @@
 void
 StackOverflowHook (lnat stack_size)    /* in bytes */
 {
-    fprintf(stderr, "Stack space overflow: current size %ld bytes.\nUse `+RTS -Ksize -RTS' to increase it.\n", stack_size);
+    fprintf(stderr, "Stack space overflow: current size %" FMT_SizeT " bytes.\nUse `+RTS -Ksize -RTS' to increase it.\n", stack_size);
 }
 
index 78ecc96..9a22dcb 100644 (file)
@@ -835,7 +835,7 @@ void findSlop(bdescr *bd)
     for (; bd != NULL; bd = bd->link) {
         slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start);
         if (slop > (1024/sizeof(W_))) {
-            debugBelch("block at %p (bdescr %p) has %ldKB slop\n",
+            debugBelch("block at %p (bdescr %p) has %" FMT_SizeT "KB slop\n",
                        bd->start, bd, slop / (1024/sizeof(W_)));
         }
     }
@@ -918,23 +918,23 @@ memInventory (rtsBool show)
           debugBelch("Memory inventory:\n");
       }
       for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-         debugBelch("  gen %d blocks : %5lu blocks (%lu MB)\n", g, 
+         debugBelch("  gen %d blocks : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", g, 
                      gen_blocks[g], MB(gen_blocks[g]));
       }
-      debugBelch("  nursery      : %5lu blocks (%lu MB)\n", 
+      debugBelch("  nursery      : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                  nursery_blocks, MB(nursery_blocks));
-      debugBelch("  retainer     : %5lu blocks (%lu MB)\n", 
+      debugBelch("  retainer     : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                  retainer_blocks, MB(retainer_blocks));
-      debugBelch("  arena blocks : %5lu blocks (%lu MB)\n", 
+      debugBelch("  arena blocks : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                  arena_blocks, MB(arena_blocks));
-      debugBelch("  exec         : %5lu blocks (%lu MB)\n", 
+      debugBelch("  exec         : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                  exec_blocks, MB(exec_blocks));
-      debugBelch("  free         : %5lu blocks (%lu MB)\n", 
+      debugBelch("  free         : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                  free_blocks, MB(free_blocks));
-      debugBelch("  total        : %5lu blocks (%lu MB)\n",
+      debugBelch("  total        : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n",
                  live_blocks + free_blocks, MB(live_blocks+free_blocks));
       if (leak) {
-          debugBelch("\n  in system    : %5lu blocks (%lu MB)\n", 
+          debugBelch("\n  in system    : %5" FMT_SizeT " blocks (%" FMT_SizeT " MB)\n", 
                      mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated);
       }
   }
index d77734f..881d427 100644 (file)
@@ -322,8 +322,8 @@ scavenge_srt (StgClosure **srt, nat srt_bitmap)
          // 
          // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
          // closure that's fixed at link-time, and no extra magic is required.
-         if ( (unsigned long)(*srt) & 0x1 ) {
-             evacuate( (StgClosure**) ((unsigned long) (*srt) & ~0x1));
+         if ( (lnat)(*srt) & 0x1 ) {
+             evacuate( (StgClosure**) ((lnat) (*srt) & ~0x1));
          } else {
              evacuate(p);
          }
index c9a759f..13bdb6f 100644 (file)
@@ -143,7 +143,7 @@ IOWorkerProc(PVOID param)
                                 * i.e., for all others, an error is raised.
                                 */
                                HANDLE h  = (HANDLE)GetStdHandle(STD_INPUT_HANDLE);
-                               if ( _get_osfhandle(work->workData.ioData.fd) == (long)h ) {
+                               if ( _get_osfhandle(work->workData.ioData.fd) == (intptr_t)h ) {
                                    if (rts_waitConsoleHandlerCompletion()) {
                                        /* If the Scheduler has set work->abandonOp, the Haskell thread has 
                                         * been thrown an exception (=> the worker must abandon this request.)
index ad897e5..e0f38d3 100644 (file)
@@ -124,7 +124,7 @@ findFreeBlocks(nat n) {
     /* TODO: Don't just take first block, find smallest sufficient block */
     for( ; it!=0 && it->size<required_size; prev=it, it=it->next ) {}
     if(it!=0) {
-        if( (((unsigned long)it->base) & MBLOCK_MASK) == 0) { /* MBlock aligned */
+        if( (((lnat)it->base) & MBLOCK_MASK) == 0) { /* MBlock aligned */
             ret = (void*)it->base;
             if(it->size==required_size) {
                 prev->next=it->next;
@@ -137,7 +137,7 @@ findFreeBlocks(nat n) {
             char* need_base;
             block_rec* next;
             int new_size;
-            need_base = (char*)(((unsigned long)it->base) & ((unsigned long)~MBLOCK_MASK)) + MBLOCK_SIZE;
+            need_base = (char*)(((lnat)it->base) & ((lnat)~MBLOCK_MASK)) + MBLOCK_SIZE;
             next = (block_rec*)stgMallocBytes(
                     sizeof(block_rec)
                     , "getMBlocks: findFreeBlocks: splitting");
index d535e34..047efcb 100644 (file)
@@ -39,7 +39,7 @@ endif
 # We filter out -Werror from SRC_CC_OPTS, because when configure tests
 # for a feature it may not generate warning-free C code, and thus may
 # think that the feature doesn't exist if -Werror is on.
-$1_$2_CONFIGURE_OPTS += --configure-option=CFLAGS="$$(filter-out -Werror,$$(SRC_CC_OPTS)) $$(CONF_CC_OPTS_STAGE$3) $$($1_CC_OPTS) $$($1_$2_CC_OPTS)"
+$1_$2_CONFIGURE_OPTS += --configure-option=CFLAGS="$$(filter-out -Werror,$$(SRC_CC_OPTS)) $$(CONF_CC_OPTS_STAGE$3) $$($1_CC_OPTS) $$($1_$2_CC_OPTS) $$(SRC_CC_WARNING_OPTS)"
 $1_$2_CONFIGURE_OPTS += --configure-option=LDFLAGS="$$(SRC_LD_OPTS) $$(CONF_GCC_LINKER_OPTS_STAGE$3) $$($1_LD_OPTS) $$($1_$2_LD_OPTS)"
 $1_$2_CONFIGURE_OPTS += --configure-option=CPPFLAGS="$$(SRC_CPP_OPTS) $$(CONF_CPP_OPTS_STAGE$3) $$($1_CPP_OPTS) $$($1_$2_CPP_OPTS)"
 
index 2e5f764..c26bbc7 100644 (file)
@@ -41,6 +41,10 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
 #                                                          mk/build.mk
 #                                                          mk/validate.mk
 #   
+#  SRC_HC_WARNING_OPTS   source-tree-wide GHC warning      mk/config.mk.in
+#                        options                           mk/build.mk
+#                                                          mk/validate.mk
+#   
 #  EXTRA_HC_OPTS         for supplying extra options on    make EXTRA_HC_OPTS=...
 #                        the command line   
 #   
@@ -102,6 +106,7 @@ $1_$2_$3_MOST_HC_OPTS = \
  $$($1_$2_EXTRA_HC_OPTS) \
  $$($1_$2_$3_HC_OPTS) \
  $$($$(basename $$<)_HC_OPTS) \
+ $$(SRC_HC_WARNING_OPTS) \
  $$(EXTRA_HC_OPTS)
 
 # NB. CONF_HC_OPTS_STAGE$4 has to be late enough to override $1_$2_HC_OPTS, so
@@ -151,7 +156,8 @@ $1_$2_DIST_CC_OPTS = \
  $$($1_$2_CC_OPTS) \
  $$($1_$2_CPP_OPTS) \
  $$($1_$2_CC_INC_FLAGS) \
- $$($1_$2_DEP_CC_OPTS)
+ $$($1_$2_DEP_CC_OPTS) \
+ $$(SRC_CC_WARNING_OPTS)
 
 ifneq ($$(strip $$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)),)
 $1_$2_DIST_LD_LIB_DIRS := $$(subst $$(space)',$$(space)-L',$$(space)$$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED))
index 20d0570..3ee2b13 100644 (file)
@@ -28,7 +28,7 @@ $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/C
 $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. bootstrapping/.
        "$(GHC)" $(SRC_HC_OPTS) --make $(GHC_CABAL_DIR)/Main.hs -o $@ \
               -no-user-package-conf \
-              -Wall $(WERROR) \
+              -Wall \
               -DCABAL_VERSION=$(CABAL_VERSION) \
               -odir  bootstrapping \
               -hidir bootstrapping \
index 11b7c8f..4f4967e 100644 (file)
@@ -55,6 +55,7 @@ utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/
        "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \
               -no-user-package-conf \
               -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \
+              $(SRC_HC_WARNING_OPTS) \
               -DCABAL_VERSION=$(CABAL_VERSION) \
               -DBOOTSTRAPPING \
               -odir  bootstrapping \