diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 07a91bf4335b1781dad294dd0ba4424722c53042..8e4d758545f3e3d90f112287ed81cfda2fab542a 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -29,7 +29,7 @@ import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_OutputLanguage, opt_EmitCExternDecls )
import Maybes ( maybeToBool )
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
import Panic ( panic )
infixr 9 `thenFlt`
@@ -331,16 +331,16 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
-flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs)
+flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
| isCandidate && opt_OutputLanguage == Just "C" -- Urgh
= returnFlt (stmt, tdef)
+ | otherwise
+ = returnFlt (stmt, AbsCNop)
where
- (isCandidate, isDyn) =
- case ccall of
- CCall (DynamicTarget _) _ _ _ -> (True, True)
- CCall (StaticTarget _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
+ isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
+ is_dynamic = isDynamicTarget target
- tdef = CCallTypedef isDyn ccall results args
+ tdef = CCallTypedef is_dynamic ccall results args
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index f3dd00099fad6bdc77fb1cf6a77c9f09d74022a9..667d1bb8f55c59960a36e4983e649402a5da727d 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -46,7 +46,7 @@ import Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
- PrimOp(..), CCall(..), CCallTarget(..) )
+ PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
@@ -821,42 +821,30 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
- ccall_fun_ty =
- ptext SLIT("_ccall_fun_ty") <>
- case op_str of
- DynamicTarget u -> ppr u
- _ -> empty
-
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
- (StaticTarget asm_str) = op_str
- is_dynamic =
- case op_str of
- StaticTarget _ -> False
- DynamicTarget _ -> True
-
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
+ StaticTarget asm_str = op_str -- Must be static if it's a casm
-- Remainder only used for ccall
- fun_name
- | is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
- | otherwise = ptext asm_str
+ fun_name = case op_str of
+ DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
+ StaticTarget st -> pprCLabelString st
ccall_str = showSDoc
(hcat [
if null non_void_results
then empty
else text "%r = ",
- lparen, fun_name, lparen,
+ lparen, parens fun_name, lparen,
hcat (punctuate comma ccall_fun_args),
text "));"
])
- ccall_fun_args
- | is_dynamic = tail ccall_args
- | otherwise = ccall_args
+ ccall_fun_args | isDynamicTarget op_str = tail ccall_args
+ | otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index b0d3fb0a049feaffe5e75e046ce47194f80fb7f9..3614d8d69715bbc4d7c5f4a559e5e3a52e8570ad 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -38,7 +38,7 @@ import Type ( unUsgTy, repType,
mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
)
import PprType ( {- instance Outputable Type -} )
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
+import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), dynamicTarget )
import Var ( TyVar )
import TysPrim ( realWorldStatePrimTy, addrPrimTy )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
@@ -141,14 +141,13 @@ dsFImport fn_id ty may_not_gc ext_name cconv
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
- (case ext_name of
- Dynamic -> getUniqueDs `thenDs` \ u ->
- returnDs (DynamicTarget u)
- ExtName fs _ -> returnDs (StaticTarget fs)) `thenDs` \ lbl ->
-
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
+ lbl = case ext_name of
+ Dynamic -> dynamicTarget
+ ExtName fs _ -> StaticTarget fs
+
-- Build the worker
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index a55af165de2428bb9e283bf8903d2ffb353bf81f..34d49c78edc3ee5dd0c2006964c4f9c7c2c559c1 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -19,7 +19,8 @@ module PrimOp (
pprPrimOp,
- CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp
+ CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
+ isDynamicTarget, dynamicTarget, setCCallUnique
) where
#include "HsVersions.h"
@@ -2418,13 +2419,34 @@ data CCallTarget
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
-- .hc code - can't do this inline for tedious reasons.)
- deriving( Eq )
+
+instance Eq CCallTarget where
+ (StaticTarget l1) == (StaticTarget l2) = l1 == l2
+ (DynamicTarget _) == (DynamicTarget _) = True
+ -- Ignore the arbitrary unique; this is important when comparing
+ -- a dynamic ccall read from an interface file A.hi with the
+ -- one constructed from A.hs, when deciding whether the interface
+ -- has changed
+ t1 == t2 = False
ccallMayGC :: CCall -> Bool
ccallMayGC (CCall _ _ may_gc _) = may_gc
ccallIsCasm :: CCall -> Bool
ccallIsCasm (CCall _ c_asm _ _) = c_asm
+
+isDynamicTarget (DynamicTarget _) = True
+isDynamicTarget (StaticTarget _) = False
+
+dynamicTarget :: CCallTarget
+dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set")
+ -- The unique is really only to do with code generation, so it
+ -- is only set in CoreToStg; before then it's just an error message
+
+setCCallUnique :: CCall -> Unique -> CCall
+setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq
+ = CCall (DynamicTarget uniq) is_asm may_gc cconv
+setCCallUnique ccall uniq = ccall
\end{code}
\begin{code}
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index fc0a8d52c704c8845118f39fde5c9c2bf79b9ad5..44cff7e9450f5eb3aa79e87b4787fd295228c2f2 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -33,7 +33,7 @@ import Demand ( Demand, isStrict, wwStrict, wwLazy )
import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
import Literal ( Literal(..) )
import VarEnv
-import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
+import PrimOp ( PrimOp(..), setCCallUnique, primOpUsg )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
splitRepFunTys, mkFunTys
@@ -657,11 +657,14 @@ mkStgApp env fn args ty
-> saturate fn_alias args ty $ \ args' ty' ->
returnUs (StgConApp dc args')
- PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
+ PrimOpId (CCallOp ccall)
-- Sigh...make a guaranteed unique name for a dynamic ccall
+ -- Done here, not earlier, because it's a code-gen thing
-> saturate fn_alias args ty $ \ args' ty' ->
- getUniqueUs `thenUs` \ u ->
- returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
+ returnUs (StgPrimApp (CCallOp ccall') args' ty')
+ where
+ ccall' = setCCallUnique ccall (idUnique fn)
+ -- The particular unique doesn't matter
PrimOpId op
-> saturate fn_alias args ty $ \ args' ty' ->