Don't share low valued Int and Char closures with Windows DLLs

7 files changed, 64 insertions, 10 deletions

diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 89a4e84400..36c851d5ba 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -165,7 +165,13 @@ which is guaranteed in range.
 
 Because of this, we use can safely return an addressing mode.
 
+We don't support this optimisation when compiling into Windows DLLs yet
+because they don't support cross package data references well.
+
 \begin{code}
+
+
+#if !(defined(__PIC__) && defined(mingw32_HOST_OS))
 buildDynCon binder _ con [arg_amode]
   | maybeIntLikeCon con 
   , (_, CmmLit (CmmInt val _)) <- arg_amode
@@ -187,6 +193,8 @@ buildDynCon binder _ con [arg_amode]
 		-- CHARLIKE closures consist of a header and one word payload
 	      charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
 	; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) }
+#endif
+
 \end{code}
 
 Now the general case.
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 452a352bab..18c2509ccd 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -147,8 +147,13 @@ work with any old argument, but for @Int@-like ones the argument has
 to be a literal.  Reason: @Char@ like closures have an argument type
 which is guaranteed in range.
 
-Because of this, we use can safely return an addressing mode. -}
+Because of this, we use can safely return an addressing mode. 
 
+We don't support this optimisation when compiling into Windows DLLs yet
+because they don't support cross package data references well.
+-}
+
+#if !(defined(__PIC__) && defined(mingw32_HOST_OS))
 buildDynCon binder _cc con [arg]
   | maybeIntLikeCon con 
   , StgLitArg (MachInt val) <- arg
@@ -172,6 +177,7 @@ buildDynCon binder _cc con [arg]
 		-- CHARLIKE closures consist of a header and one word payload
 	      charlike_amode = cmmLabelOffW charlike_lbl offsetW
 	; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
+#endif
 
 -------- buildDynCon: the general case -----------
 buildDynCon binder ccs con args
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index dae697d913..1d94b49763 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -974,14 +974,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
                         then [] 
                         else [ "-ffloat-store" ]) ++
 #endif
+
 		-- gcc's -fstrict-aliasing allows two accesses to memory
 		-- to be considered non-aliasing if they have different types.
 		-- This interacts badly with the C code we generate, which is
 		-- very weakly typed, being derived from C--.
 		["-fno-strict-aliasing"]
 
-
-
 	liftIO $ SysTools.runCc dflags (
 		-- force the C compiler to interpret this file as C when
 		-- compiling .hc files, by adding the -x c option.
@@ -997,6 +996,18 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 		       ++ map SysTools.Option (
 		          md_c_flags
                        ++ pic_c_flags
+
+#if    defined(__PIC__) && defined(mingw32_HOST_OS)
+		-- Stub files generated for foreign exports references the runIO_closure
+		-- and runNonIO_closure symbols, which are defined in the base package.
+		-- These symbols are imported into the stub.c file via RtsAPI.h, and the
+		-- way we do the import depends on whether we're currently compiling
+		-- the base package or not.
+		       ++ (if thisPackage dflags == basePackageId
+		       		then [ "-DCOMPILING_BASE_PACKAGE" ]
+				else [])
+#endif	
+
 #ifdef sparc_TARGET_ARCH
         -- We only support SparcV9 and better because V8 lacks an atomic CAS
         -- instruction. Note that the user can still override this
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
index ff2bc1120a..03dbce22a5 100644
--- a/includes/RtsAPI.h
+++ b/includes/RtsAPI.h
@@ -162,10 +162,16 @@ rts_getSchedStatus (Capability *cap);
    These are used by foreign export and foreign import "wrapper" stubs.
    ----------------------------------------------------------------------- */
 
-extern StgWord base_GHCziTopHandler_runIO_closure[];
-extern StgWord base_GHCziTopHandler_runNonIO_closure[];
-#define runIO_closure		  base_GHCziTopHandler_runIO_closure
-#define runNonIO_closure	  base_GHCziTopHandler_runNonIO_closure
+// When producing Windows DLLs the compiler needs to know which symbols
+// 	are in the local package/DLL vs external ones. 
+//	DLL_IMPORT_BASE expands to __declspec(dllimport) when we're not compiling
+//	the the base package.
+
+DLL_IMPORT_BASE extern StgWord base_GHCziTopHandler_runIO_closure[];
+DLL_IMPORT_BASE extern StgWord base_GHCziTopHandler_runNonIO_closure[];
+
+#define runIO_closure     base_GHCziTopHandler_runIO_closure
+#define runNonIO_closure  base_GHCziTopHandler_runNonIO_closure
 
 /* ------------------------------------------------------------------------ */
 
diff --git a/includes/stg/DLL.h b/includes/stg/DLL.h
index b7e7c5aaac..f08d1cd144 100644
--- a/includes/stg/DLL.h
+++ b/includes/stg/DLL.h
@@ -52,6 +52,14 @@
 # endif
 #endif
 
+
+#ifdef COMPILING_BASE_PACKAGE
+# define DLL_IMPORT_BASE 
+#else
+# define DLL_IMPORT_BASE DLLIMPORT
+#endif
+
+
 #ifdef COMPILING_STDLIB
 #define DLL_IMPORT_STDLIB
 #else
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 95b22a9211..5e74d3f55f 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -564,10 +564,12 @@ CLOSURE(stg_dummy_ret_closure,stg_dummy_ret);
 
 #if defined(__PIC__) && defined(mingw32_TARGET_OS)
 /*
- * When sticking the RTS in a DLL, we delay populating the
+ * When sticking the RTS in a Windows DLL, we delay populating the
  * Charlike and Intlike tables until load-time, which is only
  * when we've got the real addresses to the C# and I# closures.
- *
+ *	
+ *	-- this is currently broken BL 2009/11/14.
+ *	   we don't rewrite to static closures at all with Windows DLLs.
  */
 #warning Is this correct? _imp is a pointer!
 #define Char_hash_static_info _imp__ghczmprim_GHCziTypes_Czh_static_info
@@ -587,6 +589,7 @@ CLOSURE(stg_dummy_ret_closure,stg_dummy_ret);
 
 /* end the name with _closure, to convince the mangler this is a closure */
 
+#if !(defined(__PIC__) && defined(mingw32_HOST_OS))
 section "data" {
  stg_CHARLIKE_closure:
     CHARLIKE_HDR(0)
@@ -883,3 +886,5 @@ section "data" {
     INTLIKE_HDR(15)
     INTLIKE_HDR(16)	/* MAX_INTLIKE == 16 */
 }
+
+#endif // !(defined(__PIC__) && defined(mingw32_HOST_OS))
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 379fbbaffd..3212ce5852 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -549,8 +549,17 @@ loop:
       copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),stp);
       return;
 
+  // For ints and chars of low value, save space by replacing references to
+  //	these with closures with references to common, shared ones in the RTS.
+  //
+  // * Except when compiling into Windows DLLs which don't support cross-package
+  //	data references very well.
+  //
   case CONSTR_0_1:
-  { 
+  {   
+#if defined(__PIC__) && defined(mingw32_HOST_OS) 
+      copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
+#else
       StgWord w = (StgWord)q->payload[0];
       if (info == Czh_con_info &&
 	  // unsigned, so always true:  (StgChar)w >= MIN_CHARLIKE &&  
@@ -568,6 +577,7 @@ loop:
       else {
           copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,stp,tag);
       }
+#endif
       return;
   }