Merge remote-tracking branch 'origin/master' into type-nats

11 files changed, 110 insertions, 99 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 2b72a923dd..a6d878a703 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -65,7 +65,7 @@ import Bag
 import FastString
 import ForeignCall
 import MonadUtils
-import Util( equalLength )
+import Util( equalLength, filterOut )
 
 import Data.Maybe
 import Control.Monad
@@ -170,17 +170,36 @@ in repTyClD and repC.
 
 -}
 
+-- represent associated family instances
+--
+repTyClDs :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
+repTyClDs ds = liftM de_loc (mapMaybeM repTyClD ds)
+
+
 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 
-repTyClD tydecl@(L _ (TyFamily {}))
-  = repTyFamily tydecl addTyVarBinds
+repTyClD (L loc (TyFamily { tcdFlavour = flavour,
+		            tcdLName   = tc, tcdTyVars = tvs, 
+		            tcdKindSig = opt_kind }))
+  = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+           do { flav   <- repFamilyFlavour flavour
+	      ; bndrs1 <- coreList tyVarBndrTyConName bndrs
+              ; case opt_kind of 
+                  Nothing -> repFamilyNoKind flav tc1 bndrs1
+                  Just (HsBSig ki _) 
+                    -> do { ki1 <- repKind ki 
+                          ; repFamilyKind flav tc1 bndrs1 ki1 }
+              }
+       ; return $ Just (loc, dec)
+       }
 
 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, tcdKindSig = mb_kind,
 		          tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
 		          tcdCons = cons, tcdDerivs = mb_derivs }))
   = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
        ; tc_tvs <- mk_extra_tvs tvs mb_kind
-       ; dec <- addTyVarBinds tc_tvs $ \bndrs -> 
+       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> 
            do { cxt1     <- repLContext cxt
               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
@@ -198,7 +217,7 @@ repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, tcdKindSig = mb_kind,
 		          tcdCons = [con], tcdDerivs = mb_derivs }))
   = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
        ; tc_tvs <- mk_extra_tvs tvs mb_kind
-       ; dec <- addTyVarBinds tc_tvs $ \bndrs -> 
+       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> 
            do { cxt1     <- repLContext cxt
               ; opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
@@ -213,7 +232,7 @@ repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, tcdKindSig = mb_kind,
 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
                              tcdSynRhs = ty }))
   = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
-       ; dec <- addTyVarBinds tvs $ \bndrs -> 
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 
            do { opt_tys1 <- maybeMapM repLTys opt_tys   -- only for family insts
               ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
 	      ; ty1      <- repLTy ty
@@ -233,7 +252,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
  	      ; sigs1  <- rep_sigs sigs
  	      ; binds1 <- rep_binds meth_binds
 	      ; fds1   <- repLFunDeps fds
-              ; ats1   <- repLAssocFamilys ats
+              ; ats1   <- repTyClDs ats
  	      ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
 	      ; bndrs1 <- coreList tyVarBndrTyConName bndrs
  	      ; repClass cxt1 cls1 bndrs1 fds1 decls1 
@@ -275,31 +294,6 @@ mk_extra_tvs tvs (Just (HsBSig hs_kind _))
 
 
 -------------------------
--- The type variables in the head of families are treated differently when the
--- family declaration is associated.  In that case, they are usage, not binding
--- occurences.
---
-repTyFamily :: LTyClDecl Name 
-            -> ProcessTyVarBinds TH.Dec
-            -> DsM (Maybe (SrcSpan, Core TH.DecQ))
-repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
-		               tcdLName   = tc, tcdTyVars = tvs, 
-		               tcdKindSig = opt_kind }))
-            tyVarBinds
-  = do { tc1 <- lookupLOcc tc 		-- See note [Binders and occurrences] 
-       ; dec <- tyVarBinds tvs $ \bndrs ->
-           do { flav   <- repFamilyFlavour flavour
-	      ; bndrs1 <- coreList tyVarBndrTyConName bndrs
-              ; case opt_kind of 
-                  Nothing -> repFamilyNoKind flav tc1 bndrs1
-                  Just (HsBSig ki _) 
-                    -> do { ki1 <- repKind ki 
-                          ; repFamilyKind flav tc1 bndrs1 ki1 }
-              }
-       ; return $ Just (loc, dec)
-       }
-repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
-
 -- represent fundeps
 --
 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
@@ -320,24 +314,6 @@ repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
 repFamilyFlavour TypeFamily = rep2 typeFamName []
 repFamilyFlavour DataFamily = rep2 dataFamName []
 
--- represent associated family declarations
---
-repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
-repLAssocFamilys = mapM repLAssocFamily
-  where
-    repLAssocFamily tydecl@(L _ (TyFamily {})) 
-      = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
-    repLAssocFamily tydecl
-      = failWithDs msg
-      where
-        msg = ptext (sLit "Illegal associated declaration in class:") <+> 
-              ppr tydecl
-
--- represent associated family instances
---
-repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
-repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
-
 -- represent instance declarations
 --
 repInstD :: LInstDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
@@ -362,7 +338,7 @@ repInstD (L loc (ClsInstDecl ty binds prags ats))
                ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
                ; prags1 <- rep_sigs prags
-               ; ats1 <- repLAssocFamInst ats
+               ; ats1 <- repTyClDs ats
                ; decls <- coreList decQTyConName (ats1 ++ binds1 ++ prags1)
                ; repInst cxt1 inst_ty1 decls }
        ; return (Just (loc, dec)) }
@@ -632,17 +608,27 @@ addTyVarBinds tvs m
   where
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
--- Look up a list of type variables; the computations passed as the second 
--- argument gets the *new* names on Core-level as an argument
---
-lookupTyVarBinds :: ProcessTyVarBinds a
-lookupTyVarBinds tvs m =
-  do
-    let names       = hsLTyVarNames tvs
-        mkWithKinds = map repTyVarBndrWithKind tvs
-    bndrs       <- mapM lookupBinder names 
-    kindedBndrs <- zipWithM ($) mkWithKinds bndrs
-    m kindedBndrs
+
+addTyClTyVarBinds :: ProcessTyVarBinds a
+-- Used for data/newtype declarations, and family instances,
+-- so that the nested type variables work right
+--    instance C (T a) where
+--      type W (T a) = blah
+-- The 'a' in the type instance is the one bound by the instance decl
+addTyClTyVarBinds tvs m
+  = do { let tv_names = hsLTyVarNames tvs
+       ; env <- dsGetMetaEnv
+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
+       	    -- Make fresh names for the ones that are not already in scope
+            -- This makes things work for family declarations
+
+       ; term <- addBinds freshNames $ 
+	    	 do { kindedBndrs <- mapM mk_tv_bndr tvs
+	    	    ; m kindedBndrs }
+
+       ; wrapGenSyms freshNames term }
+  where
+    mk_tv_bndr tv = do { v <- lookupOcc (hsLTyVarName tv); repTyVarBndrWithKind tv v }
 
 -- Produce kinded binder constructors from the Haskell tyvar binders
 --
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index e68e6db7c2..25141362f8 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -27,7 +27,7 @@ module DsMonad (
         dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
         dsInitPArrBuiltin,
 
-        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
 
         -- Warnings
         DsWarning, warnDs, failWithDs,
@@ -480,6 +480,9 @@ dsInitPArrBuiltin thing_inside
 \end{code}
 
 \begin{code}
+dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
+dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
+
 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
index 68ab351e86..9c4c2629c3 100644
--- a/compiler/nativeGen/X86/Regs.hs
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -629,7 +629,11 @@ globalRegMaybe _                        = Nothing
 allArgRegs = panic "X86.Regs.allArgRegs: should not be used!"
 
 #elif x86_64_TARGET_ARCH
+#if defined(mingw32_HOST_OS)
+allArgRegs = map regSingle [rcx,rdx,r8,r9]
+#else
 allArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9]
+#endif
 
 #else
 allArgRegs  = panic "X86.Regs.allArgRegs: not defined for this architecture"
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 394cd9801e..076df2e67c 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -818,7 +818,7 @@ lvlLamBndrs lvl bndrs
 \end{code}
 
 \begin{code}
-  -- Destintion level is the max Id level of the expression
+  -- Destination level is the max Id level of the expression
   -- (We'll abstract the type variables, if any.)
 destLevel :: LevelEnv -> VarSet -> Bool -> Maybe (Arity, StrictSig) -> Level
 destLevel env fvs is_function mb_bot
@@ -830,6 +830,7 @@ destLevel env fvs is_function mb_bot
   , countFreeIds fvs <= n_args
   = tOP_LEVEL	-- Send functions to top level; see
 		-- the comments with isFunction
+
   | otherwise = maxFvLevel isId env fvs  -- Max over Ids only; the tyvars
     	      		   	    	 -- will be abstracted
 
diff --git a/includes/Rts.h b/includes/Rts.h
index cb23fd1083..c1f4f05bea 100644
--- a/includes/Rts.h
+++ b/includes/Rts.h
@@ -143,6 +143,24 @@ 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
  */
diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c
index 2e09409654..6f2e6de87e 100644
--- a/includes/mkDerivedConstants.c
+++ b/includes/mkDerivedConstants.c
@@ -30,7 +30,7 @@
 #define str(a,b) #a "_" #b
 
 #define OFFSET(s_type, field) ((size_t)&(((s_type*)0)->field))
-#define FIELD_SIZE(s_type, field) ((unsigned long)sizeof(((s_type*)0)->field))
+#define FIELD_SIZE(s_type, field) ((size_t)sizeof(((s_type*)0)->field))
 #define TYPE_SIZE(type) (sizeof(type))
 
 #pragma GCC poison sizeof
@@ -38,17 +38,17 @@
 #if defined(GEN_HASKELL)
 #define def_offset(str, offset)                          \
     printf("oFFSET_" str " :: Int\n");                   \
-    printf("oFFSET_" str " = %lu\n", (unsigned long)offset);
+    printf("oFFSET_" str " = %" FMT_SizeT "\n", (size_t)offset);
 #else
 #define def_offset(str, offset) \
-    printf("#define OFFSET_" str " %lu\n", (unsigned long)offset);
+    printf("#define OFFSET_" str " %" FMT_SizeT "\n", (size_t)offset);
 #endif
 
 #if defined(GEN_HASKELL)
 #define ctype(type) /* nothing */
 #else
 #define ctype(type) \
-    printf("#define SIZEOF_" #type " %lu\n", (unsigned long)TYPE_SIZE(type));
+    printf("#define SIZEOF_" #type " %" FMT_SizeT "\n", (size_t)TYPE_SIZE(type));
 #endif
 
 #if defined(GEN_HASKELL)
@@ -63,7 +63,7 @@
 */
 #define field_type_(str, s_type, field) \
     printf("#define REP_" str " b"); \
-    printf("%lu\n", FIELD_SIZE(s_type, field) * 8);
+    printf("%" FMT_SizeT "\n", FIELD_SIZE(s_type, field) * 8);
 #define field_type_gcptr_(str, s_type, field) \
     printf("#define REP_" str " gcptr\n");
 #endif
@@ -95,17 +95,17 @@
 #if defined(GEN_HASKELL)
 #define def_size(str, size)                \
     printf("sIZEOF_" str " :: Int\n");     \
-    printf("sIZEOF_" str " = %lu\n", (unsigned long)size);
+    printf("sIZEOF_" str " = %" FMT_SizeT "\n", (size_t)size);
 #else
 #define def_size(str, size) \
-    printf("#define SIZEOF_" str " %lu\n", (unsigned long)size);
+    printf("#define SIZEOF_" str " %" FMT_SizeT "\n", (size_t)size);
 #endif
 
 #if defined(GEN_HASKELL)
 #define def_closure_size(str, size) /* nothing */
 #else
 #define def_closure_size(str, size) \
-    printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%lu)\n", (unsigned long)size);
+    printf("#define SIZEOF_" str " (SIZEOF_StgHeader+%" FMT_SizeT ")\n", (size_t)size);
 #endif
 
 #define struct_size(s_type) \
@@ -193,9 +193,9 @@ main(int argc, char *argv[])
 #ifndef GEN_HASKELL
     printf("/* This file is created automatically.  Do not edit by hand.*/\n\n");
 
-    printf("#define STD_HDR_SIZE   %lu\n", (unsigned long)sizeofW(StgHeader) - sizeofW(StgProfHeader));
+    printf("#define STD_HDR_SIZE   %" FMT_SizeT "\n", (size_t)sizeofW(StgHeader) - sizeofW(StgProfHeader));
     /* grrr.. PROFILING is on so we need to subtract sizeofW(StgProfHeader) */
-    printf("#define PROF_HDR_SIZE  %lu\n", (unsigned long)sizeofW(StgProfHeader));
+    printf("#define PROF_HDR_SIZE  %" FMT_SizeT "\n", (size_t)sizeofW(StgProfHeader));
 
     printf("#define BLOCK_SIZE   %u\n", BLOCK_SIZE);
     printf("#define MBLOCK_SIZE   %u\n", MBLOCK_SIZE);
diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm
index 199f0cd378..90691fa091 100644
--- a/rts/HeapStackCheck.cmm
+++ b/rts/HeapStackCheck.cmm
@@ -679,16 +679,8 @@ INFO_TABLE_RET( stg_block_async, RET_SMALL, W_ unused )
     len = TO_W_(StgAsyncIOResult_len(ares));
     errC = TO_W_(StgAsyncIOResult_errCode(ares));
     foreign "C" free(ares "ptr");
-#ifdef GhcUnregisterised
-    Sp(1) = errC;
-    Sp(0) = len;
-    jump %ENTRY_CODE(Sp(2));
-#else
-    R1 = len;
-    Sp_adj(1);
-    Sp(0) = errC;
-    jump %ENTRY_CODE(Sp(1));
-#endif
+    Sp_adj(2);
+    RET_NN(len, errC);
 }
 
 stg_block_async
diff --git a/rts/Schedule.c b/rts/Schedule.c
index aa22e06bd9..7dca76438b 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -611,7 +611,7 @@ schedulePreLoop(void)
 {
   // initialisation for scheduler - what cannot go into initScheduler()  
 
-#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && !defined(GhcUnregisterised)
+#if defined(mingw32_HOST_OS) && !defined(GhcUnregisterised)
     win32AllocStack();
 #endif
 }
diff --git a/rts/StgCRun.c b/rts/StgCRun.c
index f08e35dd11..15f9fd26a8 100644
--- a/rts/StgCRun.c
+++ b/rts/StgCRun.c
@@ -98,6 +98,18 @@ StgFunPtr StgReturn(void)
 #define STG_RETURN "StgReturn"
 #endif
 
+#if defined(mingw32_HOST_OS)
+// On windows the stack has to be allocated 4k at a time, otherwise
+// we get a segfault.  The C compiler knows how to do this (it calls
+// _alloca()), so we make sure that we can allocate as much stack as
+// we need:
+StgWord8 *win32AllocStack(void)
+{
+    StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12];
+    return stack;
+}
+#endif
+
 /* -----------------------------------------------------------------------------
    x86 architecture
    -------------------------------------------------------------------------- */
@@ -211,18 +223,6 @@ StgRunIsImplementedInAssembler(void)
     );
 }
 
-#if defined(mingw32_HOST_OS)
-// On windows the stack has to be allocated 4k at a time, otherwise
-// we get a segfault.  The C compiler knows how to do this (it calls
-// _alloca()), so we make sure that we can allocate as much stack as
-// we need:
-StgWord8 *win32AllocStack(void)
-{
-    StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12];
-    return stack;
-}
-#endif
-
 #endif
 
 /* ----------------------------------------------------------------------------
@@ -259,11 +259,19 @@ StgRunIsImplementedInAssembler(void)
         /*
          * Set BaseReg
          */
+#if defined(mingw32_HOST_OS)
+        "movq %%rdx,%%r13\n\t"
+#else
         "movq %%rsi,%%r13\n\t"
+#endif
         /*
          * grab the function argument from the stack, and jump to it.
          */
+#if defined(mingw32_HOST_OS)
+        "movq %%rcx,%%rax\n\t"
+#else
         "movq %%rdi,%%rax\n\t"
+#endif
         "jmp *%%rax\n\t"
 
         ".globl " STG_RETURN "\n"
diff --git a/rts/ghc.mk b/rts/ghc.mk
index e5fff56008..95faea8f77 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -312,7 +312,6 @@ rts/RtsUtils_CC_OPTS += -DGhcUnregisterised=\"$(GhcUnregisterised)\"
 rts/RtsUtils_CC_OPTS += -DGhcEnableTablesNextToCode=\"$(GhcEnableTablesNextToCode)\"
 
 ifeq "$(GhcUnregisterised)" "YES"
-rts/HeapStackCheck_HC_OPTS += -DGhcUnregisterised=1
 rts/PrimOps_HC_OPTS += -DGhcUnregisterised=1
 rts/Schedule_CC_OPTS += -DGhcUnregisterised=1
 endif
diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c
index afcdc19d27..9561ea6aea 100644
--- a/rts/win32/ThrIOManager.c
+++ b/rts/win32/ThrIOManager.c
@@ -152,7 +152,7 @@ ioManagerStart (void)
     Capability *cap;

     if (io_manager_event == INVALID_HANDLE_VALUE) {

 	cap = rts_lock();

-#if defined(mingw32_HOST_OS) && defined(i386_HOST_Arch) && defined(__PIC__)

+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH) && defined(__PIC__)

         rts_evalIO(&cap,_imp__base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);

 #else

         rts_evalIO(&cap,&base_GHCziConcziIO_ensureIOManagerIsRunning_closure,NULL);