Refactor PackageTarget back into StaticTarget

diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 879d043..901dd96 100644 (file)
--- 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 bda9e0f..b98da50 100644 (file)
--- 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 3eb9cd9..eae4b93 100644 (file)
--- 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 0dd29c9..f46d99e 100644 (file)
--- 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 c2d83d6..e95df4d 100644 (file)
--- 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 99e896c..5d1bd27 100644 (file)
--- 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 0312dcb..607b319 100644 (file)
--- 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 f43e225..0289cfc 100644 (file)
--- 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 f230187..d18b8d8 100644 (file)
--- 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 578ab3c..4423d03 100644 (file)
--- 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 2911ce0..bfecfd6 100644 (file)
--- 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 f49f092..edda603 100644 (file)
--- 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 1901357..fdb7ce5 100644 (file)
--- 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)