Refactor PackageTarget back into StaticTarget

13 files changed, 46 insertions, 68 deletions

diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 879d043329..901dd96502 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -78,16 +78,9 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
   where
       (call_args, cmm_target)
 	= case target of
-
-	   -- A target label known to be in the current package.
-	   StaticTarget lbl 
-	    -> ( args
-	       , CmmLit (CmmLabel 
-			(mkForeignLabel lbl call_size ForeignLabelInThisPackage IsFunction)))
-
 	   -- If the packageId is Nothing then the label is taken to be in the
 	   --	package currently being compiled.
-	   PackageTarget lbl mPkgId
+	   StaticTarget lbl mPkgId
 	    -> let labelSource 
 	    		= case mPkgId of
 				Nothing		-> ForeignLabelInThisPackage
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index bda9e0fe1b..b98da50f25 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -56,11 +56,17 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
   = do	{ cmm_args <- getFCallArgs stg_args
         ; let ((call_args, arg_hints), cmm_target)
                 = case target of
-                    StaticTarget lbl ->
-                      (unzip cmm_args,
-                       CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args)
-                                                        ForeignLabelInThisPackage IsFunction)))
-                    DynamicTarget    ->  case cmm_args of
+                   StaticTarget lbl mPkgId 
+		     -> let labelSource
+				= case mPkgId of
+					Nothing		-> ForeignLabelInThisPackage
+					Just pkgId	-> ForeignLabelInPackage pkgId
+			    size	= call_size cmm_args
+			in  ( unzip cmm_args
+			    , CmmLit (CmmLabel 
+					(mkForeignLabel lbl size labelSource IsFunction)))
+ 
+                   DynamicTarget    ->  case cmm_args of
                                            (fn,_):rest -> (unzip rest, fn)
                                            [] -> panic "cgForeignCall []"
               fc = ForeignConvention cconv arg_hints result_hints
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 3eb9cd98e0..eae4b93265 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -129,7 +129,7 @@ make_exp (Var v) = do
   isLocal <- isALocal vName
   return $
      case idDetails v of
-       FCallId (CCall (CCallSpec (StaticTarget nm) callconv _)) 
+       FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _)) 
            -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
        FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
            -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 0dd29c988f..f46d99e504 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -91,7 +91,7 @@ dsCCall lbl args may_gc result_ty
        (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
        let
-           target = StaticTarget lbl
+           target = StaticTarget lbl Nothing
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
            the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index c2d83d65b0..e95df4dbd5 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -338,10 +338,10 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
  where
     conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
     conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
-    conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
     conv_cimportspec CWrapper = return "wrapper"
     static = case cis of
-                 CFunction (StaticTarget _) -> "static "
+                 CFunction (StaticTarget _ _) -> "static "
                  _ -> ""
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 99e896c024..5d1bd27ca8 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1029,20 +1029,7 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
                  DynamicTarget
                     -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
 
-                 PackageTarget target _
-                    -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
-                          return (True, res)
-                   where
-                      stdcall_adj_target
-#ifdef mingw32_TARGET_OS
-                          | StdCallConv <- cconv
-                          = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
-                            mkFastString (unpackFS target ++ '@':show size)
-#endif
-                          | otherwise
-                          = target
-
-                 StaticTarget target
+                 StaticTarget target _
                     -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
                           return (True, res)
                    where
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 0312dcb197..607b319dd2 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -940,9 +940,7 @@ instance Outputable ForeignImport where
 
       pprCEntity (CLabel lbl) = 
         ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
-      pprCEntity (CFunction (StaticTarget lbl)) = 
-        ptext (sLit "static") <+> pp_hdr <+> ppr lbl
-      pprCEntity (CFunction (PackageTarget lbl _)) =
+      pprCEntity (CFunction (StaticTarget lbl _)) = 
         ptext (sLit "static") <+> pp_hdr <+> ppr lbl
       pprCEntity (CFunction (DynamicTarget)) =
         ptext (sLit "dynamic")
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index f43e225041..0289cfcc0d 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -277,7 +277,7 @@ exp	:: { IfaceExpr }
 --	       "InlineMe"   -> IfaceNote IfaceInlineMe $3
 --            }
         | '%external' STRING aty   { IfaceFCall (ForeignCall.CCall 
-                                                    (CCallSpec (StaticTarget (mkFastString $2)) 
+                                                    (CCallSpec (StaticTarget (mkFastString $2) Nothing) 
                                                                CCallConv (PlaySafe False))) 
                                                  $3 }
 
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index f230187983..d18b8d8fd9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -985,7 +985,7 @@ mkImport :: CCallConv
 	 -> P (HsDecl RdrName)
 mkImport cconv safety (L loc entity, v, ty)
   | cconv == PrimCallConv                      = do
-  let funcTarget = CFunction (PackageTarget entity Nothing)
+  let funcTarget = CFunction (StaticTarget entity Nothing)
       importSpec = CImport PrimCallConv safety nilFS funcTarget
   return (ForD (ForeignImport v ty importSpec))
 
@@ -1023,7 +1023,7 @@ parseCImport cconv safety nm str =
    id_char  c = isAlphaNum c || c == '_'
 
    cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
-             +++ ((\c -> CFunction (PackageTarget c Nothing)) <$> cid)
+             +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
           where 
             cid = return nm +++
                   (do c  <- satisfy (\c -> isAlpha c || c == '_')
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 578ab3c0df..4423d0317c 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -103,17 +103,23 @@ The call target:
 
 \begin{code}
 
--- | How to call a particular function in C land.
+-- | How to call a particular function in C-land.
 data CCallTarget
-  -- An "unboxed" ccall# to named function
-  = StaticTarget  CLabelString  
+  -- An "unboxed" ccall# to named function in a particular package.
+  = StaticTarget  
+	CLabelString  			-- C-land name of label.
+
+	(Maybe PackageId)		-- What package the function is in.
+					-- If Nothing, then it's taken to be in the current package.
+					-- Note: This information is only used for PrimCalls on Windows.
+					--	 See CLabel.labelDynamic and CoreToStg.coreToStgApp 
+					--	 for the difference in representation between PrimCalls
+					--	 and ForeignCalls. If the CCallTarget is representing
+					--	 a regular ForeignCall then it's safe to set this to Nothing.
 
   -- The first argument of the import is the name of a function pointer (an Addr#).
   --	Used when importing a label as "foreign import ccall "dynamic" ..."
   | DynamicTarget
-
-  -- An "unboxed" ccall# to a named function from a particular package.
-  | PackageTarget CLabelString (Maybe PackageId)
   
   deriving( Eq )
   {-! derive: Binary !-}
@@ -197,17 +203,14 @@ instance Outputable CCallSpec where
       gc_suf | playSafe safety = text "_GC"
 	     | otherwise       = empty
 
-      ppr_fun DynamicTarget     
-        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
-
-      ppr_fun (PackageTarget fn Nothing)
+      ppr_fun (StaticTarget fn Nothing)
      	= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
 
-      ppr_fun (PackageTarget fn (Just pkgId))
+      ppr_fun (StaticTarget fn (Just pkgId))
      	= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
 
-      ppr_fun (StaticTarget fn) 
-        = text "__ccall"     <> gc_suf <+> pprCLabelString fn
+      ppr_fun DynamicTarget     
+        = text "__dyn_ccall" <> gc_suf <+> text "\"\""
 \end{code}
 
 
@@ -257,24 +260,19 @@ instance Binary CCallSpec where
 	  return (CCallSpec aa ab ac)
 
 instance Binary CCallTarget where
-    put_ bh (StaticTarget aa) = do
+    put_ bh (StaticTarget aa ab) = do
 	    putByte bh 0
 	    put_ bh aa
+            put_ bh ab
     put_ bh DynamicTarget = do
 	    putByte bh 1
-    put_ bh (PackageTarget aa ab) = do
-    	    putByte bh 2
-	    put_ bh aa
-	    put_ bh ab
     get bh = do
 	    h <- getByte bh
 	    case h of
 	      0 -> do aa <- get bh
-		      return (StaticTarget aa)
-	      1 -> do return DynamicTarget
-	      _ -> do aa <- get bh
-	      	      ab <- get bh
-		      return (PackageTarget aa ab)
+                      ab <- get bh
+		      return (StaticTarget aa ab)
+	      _ -> do return DynamicTarget
 
 instance Binary CCallConv where
     put_ bh CCallConv = do
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 2911ce0120..bfecfd631f 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -412,8 +412,8 @@ patchCImportSpec packageId spec
 patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
 patchCCallTarget packageId callTarget
  = case callTarget of
- 	PackageTarget label Nothing
-	 -> PackageTarget label (Just packageId)
+ 	StaticTarget label Nothing
+	 -> StaticTarget label (Just packageId)
 
 	_			-> callTarget	
 
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index f49f092b64..edda603007 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -534,7 +534,7 @@ coreToStgApp _ f args = do
 				    StgOpApp (StgPrimOp op) args' res_ty
 
 		-- A call to some primitive Cmm function.
-		FCallId (CCall (CCallSpec (PackageTarget lbl (Just pkgId)) PrimCallConv _))
+		FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
 		                 -> ASSERT( saturated )
 				    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
 
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 19013574aa..fdb7ce5f23 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -162,11 +162,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
 -- This makes a convenient place to check
 -- that the C identifier is valid for C
 checkCTarget :: CCallTarget -> TcM ()
-checkCTarget (StaticTarget str) = do
-    checkCg checkCOrAsmOrDotNetOrInterp
-    check (isCLabelString str) (badCName str)
-
-checkCTarget (PackageTarget str _) = do
+checkCTarget (StaticTarget str _) = do
     checkCg checkCOrAsmOrDotNetOrInterp
     check (isCLabelString str) (badCName str)