Merge branch 'master' of http://darcs.haskell.org/ghc

7 files changed, 53 insertions, 45 deletions

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 15d547eab0..5d045a80a9 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -346,8 +346,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
     do	{ let bndrs' = [var | RuleBndr (L _ var) <- vars]
 
-        ; lhs' <- unsetOptM Opt_EnableRewriteRules $
-                  unsetOptM Opt_WarnIdentities $
+        ; lhs' <- unsetDOptM Opt_EnableRewriteRules $
+                  unsetWOptM Opt_WarnIdentities $
                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
 
 	; rhs' <- dsLExpr rhs
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 11eedbe496..a68214d1b1 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) 	      = dsOverLit lit
 dsExpr (HsWrap co_fn e)
   = do { co_fn' <- dsHsWrapper co_fn
        ; e' <- dsExpr e
-       ; warn_id <- doptDs Opt_WarnIdentities
+       ; warn_id <- woptDs Opt_WarnIdentities
        ; when warn_id $ warnAboutIdentities e' co_fn'
        ; return (co_fn' e') }
 
@@ -830,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
 warnDiscardedDoBindings rhs rhs_ty
   | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
   = do {  -- Warn about discarding non-() things in 'monadic' binding
-       ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+       ; warn_unused <- woptDs Opt_WarnUnusedDoBind
        ; if warn_unused && not (isUnitTy elt_ty)
          then warnDs (unusedMonadBind rhs elt_ty)
          else 
          -- Warn about discarding m a things in 'monadic' binding of the same type,
          -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
-    do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+    do { warn_wrong <- woptDs Opt_WarnWrongDoBind
        ; case tcSplitAppTy_maybe elt_ty of
            Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
                               -> warnDs (wrongMonadBind rhs elt_ty)
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index b391b8f02a..6d73d1d2bb 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -40,6 +40,8 @@ import BasicTypes
 import SrcLoc
 import Outputable
 import FastString
+import DynFlags
+import Platform
 import Config
 import Constants
 import OrdList
@@ -298,8 +300,9 @@ dsFExport fn_id ty ext_name cconv isDyn=  do
            Nothing                    -> return (orig_res_ty, False) 
                    -- The function returns t
     
+    dflags <- getDOpts
     return $
-      mkFExportCBits ext_name 
+      mkFExportCBits dflags ext_name
                      (if isDyn then Nothing else Just fn_id)
                      fe_arg_tys res_ty is_IO_res_ty cconv
 \end{code}
@@ -420,7 +423,8 @@ The C stub constructs the application of the exported Haskell function
 using the hugs/ghc rts invocation API.
 
 \begin{code}
-mkFExportCBits :: FastString
+mkFExportCBits :: DynFlags
+               -> FastString
 	       -> Maybe Id 	-- Just==static, Nothing==dynamic
 	       -> [Type] 
 	       -> Type 
@@ -431,7 +435,7 @@ mkFExportCBits :: FastString
 		   String, 	-- the argument reps
 		   Int		-- total size of arguments
 		  )
-mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 
  = (header_bits, c_bits, type_string,
     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
 	 -- NB. the calculation here isn't strictly speaking correct.
@@ -474,7 +478,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
   -- add some auxiliary args; the stable ptr in the wrapper case, and
   -- a slot for the dummy return address in the wrapper + ccall case
   aug_arg_info
-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
     | otherwise              = arg_info
 
   stable_ptr_arg = 
@@ -627,26 +631,27 @@ typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of
                  Just (tc,_) -> tc
 	         Nothing     -> pprPanic "DsForeign.typeTyCon" (ppr ty)
 
-insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)]
-                           -> [(SDoc, SDoc, Type, CmmType)]
-#if !defined(x86_64_TARGET_ARCH)
-insertRetAddr CCallConv args = ret_addr_arg : args
-insertRetAddr _ args = args
-#else
--- On x86_64 we insert the return address after the 6th
--- integer argument, because this is the point at which we
--- need to flush a register argument to the stack (See rts/Adjustor.c for
--- details).
-insertRetAddr CCallConv args = go 0 args
-  where  go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-                   -> [(SDoc, SDoc, Type, CmmType)]
-         go 6 args = ret_addr_arg : args
-	 go n (arg@(_,_,_,rep):args)
-	  | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
-	  | otherwise  = arg : go n     args
-	 go _ [] = []
-insertRetAddr _ args = args
-#endif
+insertRetAddr :: DynFlags -> CCallConv
+              -> [(SDoc, SDoc, Type, CmmType)]
+              -> [(SDoc, SDoc, Type, CmmType)]
+insertRetAddr dflags CCallConv args
+    = case platformArch (targetPlatform dflags) of
+      ArchX86_64 ->
+          -- On x86_64 we insert the return address after the 6th
+          -- integer argument, because this is the point at which we
+          -- need to flush a register argument to the stack (See
+          -- rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 6 args = ret_addr_arg : args
+              go n (arg@(_,_,_,rep):args)
+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
+               | otherwise  = arg : go n     args
+              go _ [] = []
+          in go 0 args
+      _ ->
+          ret_addr_arg : args
+insertRetAddr _ _ args = args
 
 ret_addr_arg :: (SDoc, SDoc, Type, CmmType)
 ret_addr_arg = (text "original_return_addr", text "void*", undefined, 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7538e310ce..8d0082ad21 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -351,8 +351,7 @@ repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
 repSafety PlayInterruptible = rep2 interruptibleName []
-repSafety (PlaySafe False) = rep2 safeName []
-repSafety (PlaySafe True) = rep2 threadsafeName []
+repSafety PlaySafe = rep2 safeName []
 
 ds_msg :: SDoc
 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
@@ -1798,7 +1797,6 @@ templateHaskellNames = [
     -- Safety
     unsafeName,
     safeName,
-    threadsafeName,
     interruptibleName,
     -- InlineSpec
     inlineSpecNoPhaseName, inlineSpecPhaseName,
@@ -2048,10 +2046,9 @@ cCallName = libFun (fsLit "cCall") cCallIdKey
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
 
 -- data Safety = ...
-unsafeName, safeName, threadsafeName, interruptibleName :: Name
+unsafeName, safeName, interruptibleName :: Name
 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
-threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
 -- data InlineSpec = ...
@@ -2331,10 +2328,9 @@ cCallIdKey      = mkPreludeMiscIdUnique 394
 stdCallIdKey    = mkPreludeMiscIdUnique 395
 
 -- data Safety = ...
-unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
 unsafeIdKey        = mkPreludeMiscIdUnique 400
 safeIdKey          = mkPreludeMiscIdUnique 401
-threadsafeIdKey    = mkPreludeMiscIdUnique 402
 interruptibleIdKey = mkPreludeMiscIdUnique 403
 
 -- data InlineSpec =
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 62e805334e..1dd347be98 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -9,7 +9,7 @@
 module DsMonad (
 	DsM, mapM, mapAndUnzipM,
 	initDs, initDsTc, fixDs,
-	foldlM, foldrM, ifDOptM, unsetOptM,
+	foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM,
 	Applicative(..),(<$>),
 
         newLocalName,
@@ -20,7 +20,7 @@ module DsMonad (
         mkPrintUnqualifiedDs,
         newUnique, 
         UniqSupply, newUniqueSupply,
-        getDOptsDs, getGhcModeDs, doptDs,
+        getDOptsDs, getGhcModeDs, doptDs, woptDs,
         dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
         dsLookupClass,
 
@@ -257,6 +257,9 @@ getDOptsDs = getDOpts
 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 doptDs = doptM
 
+woptDs :: WarningFlag -> TcRnIf gbl lcl Bool
+woptDs = woptM
+
 getGhcModeDs :: DsM GhcMode
 getGhcModeDs =  getDOptsDs >>= return . ghcMode
 
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 1a044d3471..25dab9370c 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs
   where 
     (pats, eqns_shadow) = check qs
     incomplete = incomplete_flag hs_ctx && (notNull pats)
-    shadow     = dopt Opt_WarnOverlappingPatterns dflags
+    shadow     = wopt Opt_WarnOverlappingPatterns dflags
               	 && notNull eqns_shadow
 
     incomplete_flag :: HsMatchContext id -> Bool
-    incomplete_flag (FunRhs {})   = dopt Opt_WarnIncompletePatterns dflags
-    incomplete_flag CaseAlt       = dopt Opt_WarnIncompletePatterns dflags
+    incomplete_flag (FunRhs {})   = wopt Opt_WarnIncompletePatterns dflags
+    incomplete_flag CaseAlt       = wopt Opt_WarnIncompletePatterns dflags
 
-    incomplete_flag LambdaExpr    = dopt Opt_WarnIncompleteUniPatterns dflags
-    incomplete_flag PatBindRhs    = dopt Opt_WarnIncompleteUniPatterns dflags
-    incomplete_flag ProcExpr      = dopt Opt_WarnIncompleteUniPatterns dflags
+    incomplete_flag LambdaExpr    = wopt Opt_WarnIncompleteUniPatterns dflags
+    incomplete_flag PatBindRhs    = wopt Opt_WarnIncompleteUniPatterns dflags
+    incomplete_flag ProcExpr      = wopt Opt_WarnIncompleteUniPatterns dflags
 
-    incomplete_flag RecUpd        = dopt Opt_WarnIncompletePatternsRecUpd dflags
+    incomplete_flag RecUpd        = wopt Opt_WarnIncompletePatternsRecUpd dflags
 
     incomplete_flag ThPatQuote    = False
     incomplete_flag (StmtCtxt {}) = False  -- Don't warn about incomplete patterns
diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 0bd2538937..173bad999c 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -65,6 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s))
 dsLit (HsCharPrim   c) = return (Lit (MachChar c))
 dsLit (HsIntPrim    i) = return (Lit (MachInt i))
 dsLit (HsWordPrim   w) = return (Lit (MachWord w))
+dsLit (HsInt64Prim  i) = return (Lit (MachInt64 i))
+dsLit (HsWord64Prim w) = return (Lit (MachWord64 w))
 dsLit (HsFloatPrim  f) = return (Lit (MachFloat (fl_value f)))
 dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
 
@@ -111,6 +113,8 @@ hsLitKey :: HsLit -> Literal
 -- others have been removed by tidy
 hsLitKey (HsIntPrim     i) = mkMachInt  i
 hsLitKey (HsWordPrim    w) = mkMachWord w
+hsLitKey (HsInt64Prim   i) = mkMachInt64  i
+hsLitKey (HsWord64Prim  w) = mkMachWord64 w
 hsLitKey (HsCharPrim    c) = MachChar   c
 hsLitKey (HsStringPrim  s) = MachStr    s
 hsLitKey (HsFloatPrim   f) = MachFloat  (fl_value f)