diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index c8eaaa8390b3c44bcde25ce335f46f4bdbed80e4..05972fab4300a11612da316ecd81be8400fb45b6 100644
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -150,6 +150,17 @@ stored in a mixed type location.)
| CCallProfCtrMacro FAST_STRING [CAddrMode]
| CCallProfCCMacro FAST_STRING [CAddrMode]
+ {- The presence of this constructor is a makeshift solution;
+ it being used to work around a gcc-related problem of
+ handling typedefs within statement blocks (or, rather,
+ the inability to do so.)
+
+ The AbstractC flattener takes care of lifting out these
+ typedefs if needs be (i.e., when generating .hc code and
+ compiling 'foreign import dynamic's)
+ -}
+ | CCallTypedef PrimOp{-CCallOp-} [CAddrMode] [CAddrMode]
+
-- *** the next three [or so...] are DATA (those above are CODE) ***
| CStaticClosure
diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index 940e1d52a56fefe7e49f912a69eb4bcc44f50ad3..a8f97564ff6d0ffc6e48046dd78217f026a3086b 100644
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -32,6 +32,9 @@ import PrimRep ( getPrimRepSize, PrimRep(..) )
import Unique ( Unique{-instance Eq-} )
import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
import Util ( assocDefaultUsing, panic )
+import CmdLineOpts ( opt_ProduceC )
+import Maybes ( maybeToBool )
+import PrimOp ( PrimOp(..) )
infixr 9 `thenFlt`
\end{code}
@@ -444,6 +447,14 @@ flatAbsC stmt@(CInitHdr a b cc u)
= flatAmode cc `thenFlt` \ (new_cc, tops) ->
returnFlt (CInitHdr a b new_cc u, tops)
+flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
+ | maybeToBool opt_ProduceC
+ = flatAmodes results `thenFlt` \ (results_here, tops1) ->
+ flatAmodes args `thenFlt` \ (args_here, tops2) ->
+ let tdef = CCallTypedef td results args in
+ returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
+ mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
+
flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
= flatAmodes results `thenFlt` \ (results_here, tops1) ->
flatAmodes args `thenFlt` \ (args_here, tops2) ->
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index fe78a3d085b7d6aa3646c82352f79b642aa86332..ce7180e447d41caaa3079bbb88cc751ab92aa731 100644
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -233,6 +233,39 @@ pprAbsC stmt@(CCallProfCtrMacro op as) _
pprAbsC stmt@(CCallProfCCMacro op as) _
= hcat [ptext op, lparen,
hcat (punctuate comma (map ppr_amode as)),pp_paren_semi]
+pprAbsC stmt@(CCallTypedef op@(CCallOp op_str is_asm may_gc cconv _ _) results args) _
+ = hsep [ ptext SLIT("typedef")
+ , ccall_res_ty
+ , fun_nm
+ , parens (hsep (punctuate comma ccall_decl_ty_args))
+ ] <> semi
+ where
+ fun_nm = parens (text (callConvAttribute cconv) <+> char '*' <> ccall_fun_ty)
+
+ ccall_fun_ty =
+ case op_str of
+ Right u -> ptext SLIT("_ccall_fun_ty") <> ppr u
+
+ ccall_res_ty =
+ case non_void_results of
+ [] -> ptext SLIT("void")
+ [amode] -> text (showPrimRep (getAmodeRep amode))
+ _ -> panic "pprAbsC{CCallTypedef}: ccall_res_ty"
+
+ ccall_decl_ty_args = tail ccall_arg_tys
+ ccall_arg_tys = map (text.showPrimRep.getAmodeRep) non_void_args
+
+ -- the first argument will be the "I/O world" token (a VoidRep)
+ -- all others should be non-void
+ non_void_args =
+ let nvas = tail args
+ in ASSERT (all non_void nvas) nvas
+
+ -- there will usually be two results: a (void) state which we
+ -- should ignore and a (possibly void) result.
+ non_void_results =
+ let nvrs = grab_non_void_amodes results
+ in ASSERT (length nvrs <= 1) nvrs
pprAbsC (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
@@ -604,10 +637,10 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
else
vcat [
char '{',
- declare_fun_extern, -- declare expected function type.
declare_local_vars, -- local var for *result*
vcat local_arg_decls,
pp_save_context,
+ declare_fun_extern, -- declare expected function type.
process_casm local_vars pp_non_void_args casm_str,
pp_restore_context,
assign_results,
@@ -673,7 +706,7 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
-}
declare_fun_extern
- | is_asm || not opt_EmitCExternDecls = empty
+ | is_dynamic || is_asm || not opt_EmitCExternDecls = empty
| otherwise =
hsep [ typedef_or_extern
, ccall_res_ty
@@ -702,13 +735,20 @@ pprCCall op@(CCallOp op_str is_asm may_gc cconv _ _) args results liveness_mask
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
- ccall_fun_ty = ptext SLIT("_ccall_fun_ty")
+ ccall_fun_ty =
+ ptext SLIT("_ccall_fun_ty") <>
+ case op_str of
+ Right u -> ppr u
+ _ -> empty
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results pp_liveness
- (Just asm_str) = op_str
- is_dynamic = not (maybeToBool op_str)
+ (Left asm_str) = op_str
+ is_dynamic =
+ case op_str of
+ Left _ -> False
+ _ -> True
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs
index 73630c661ce6a31de326773a1d776a0c26a27da4..511c2882b8e12f444c56b55dae44481178d7abf6 100644
--- a/ghc/compiler/deSugar/DsCCall.lhs
+++ b/ghc/compiler/deSugar/DsCCall.lhs
@@ -96,7 +96,7 @@ dsCCall label args may_gc is_asm io_result_ty
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
let
- the_ccall_op = CCallOp (Just label) is_asm may_gc cCallConv
+ the_ccall_op = CCallOp (Left label) is_asm may_gc cCallConv
(map coreExprType final_args)
final_result_ty
in
diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index 2a855aff37de4979b22c416b4217acbe7e3dc845..f495cd2c237539d53b9f17d566a0e9ea4c9f27e9 100644
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -116,12 +116,10 @@ dsFImport nm ty may_not_gc ext_name cconv =
(ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
in
boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
+ (case ext_name of
+ Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
+ ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
let
- label =
- case ext_name of
- Dynamic -> Nothing
- ExtName fs _ -> Just fs
-
the_ccall_op = CCallOp label False (not may_not_gc) cconv
(map coreExprType final_args)
final_result_ty
@@ -348,7 +346,7 @@ dsFExportDynamic i ty ext_name cconv =
Var stbl,
Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
- label = Just SLIT("createAdjustor")
+ label = Left SLIT("createAdjustor")
the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
(map coreExprType ccall_args)
stateAndAddrPrimTy
diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs
index c23c743a6ce10afa1acc55df9f0135a83ab86f22..92792420ba3582637f5dd4685986c894511ce531 100644
--- a/ghc/compiler/nativeGen/StixPrim.lhs
+++ b/ghc/compiler/nativeGen/StixPrim.lhs
@@ -445,7 +445,7 @@ primCode [lhs] SeqOp [a]
-- trace "SeqOp" $
returnUs (\xs -> assign : xs)
-primCode lhs (CCallOp (Just fn) is_asm may_gc cconv arg_tys result_ty) rhs
+primCode lhs (CCallOp (Left fn) is_asm may_gc cconv arg_tys result_ty) rhs
| is_asm = error "ERROR: Native code generator can't handle casm"
| may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
| otherwise
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index aa416737b637f4b12cc11016457b927d24c56d3a..71ad73378b4d4709db2f264adbcb8ef1d753d369 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -169,8 +169,11 @@ data PrimOp
A special ``trap-door'' to use in making calls direct to C functions:
\begin{code}
- | CCallOp (Maybe FAST_STRING) -- Nothing => first argument (an Addr#) is the function pointer
- -- Just fn => An "unboxed" ccall# to `fn'.
+ | CCallOp (Either
+ FAST_STRING -- Left fn => An "unboxed" ccall# to `fn'.
+ Unique) -- Right u => first argument (an Addr#) is the function pointer
+ -- (unique is used to
+
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
@@ -402,90 +405,98 @@ tagOf_PrimOp (NewByteArrayOp WordRep) = ILIT(126)
tagOf_PrimOp (NewByteArrayOp AddrRep) = ILIT(127)
tagOf_PrimOp (NewByteArrayOp FloatRep) = ILIT(128)
tagOf_PrimOp (NewByteArrayOp DoubleRep) = ILIT(129)
-tagOf_PrimOp SameMutableArrayOp = ILIT(130)
-tagOf_PrimOp SameMutableByteArrayOp = ILIT(131)
-tagOf_PrimOp ReadArrayOp = ILIT(132)
-tagOf_PrimOp WriteArrayOp = ILIT(133)
-tagOf_PrimOp IndexArrayOp = ILIT(134)
-tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(135)
-tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(136)
-tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(137)
-tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(138)
-tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(139)
-tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(140)
-tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(141)
-tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(142)
-tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(143)
-tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(144)
-tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(145)
-tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(146)
-tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(147)
-tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(148)
-tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(149)
-tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(150)
-tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(151)
-tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(152)
-tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(153)
-tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(154)
-tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(155)
-tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(156)
-tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(157)
-tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(158)
-tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(159)
-tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(160)
-tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(161)
-tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(162)
-tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(163)
-tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(164)
-tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(165)
-tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(166)
-tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(167)
-tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(168)
-tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(169)
-tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(170)
-tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(171)
-tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(172)
-tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(173)
-tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(174)
-tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(175)
-tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(176)
-tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(177)
-tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(178)
-tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(179)
-tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(180)
-tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(181)
-tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(182)
-tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(183)
-tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(184)
-tagOf_PrimOp SizeofByteArrayOp = ILIT(185)
-tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(186)
-tagOf_PrimOp NewSynchVarOp = ILIT(187)
-tagOf_PrimOp TakeMVarOp = ILIT(188)
-tagOf_PrimOp PutMVarOp = ILIT(189)
-tagOf_PrimOp ReadIVarOp = ILIT(190)
-tagOf_PrimOp WriteIVarOp = ILIT(191)
-tagOf_PrimOp MakeForeignObjOp = ILIT(192)
-tagOf_PrimOp WriteForeignObjOp = ILIT(193)
-tagOf_PrimOp MakeStablePtrOp = ILIT(194)
-tagOf_PrimOp DeRefStablePtrOp = ILIT(195)
-tagOf_PrimOp (CCallOp _ _ _ _ _ _) = ILIT(196)
-tagOf_PrimOp ErrorIOPrimOp = ILIT(197)
-tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(198)
-tagOf_PrimOp SeqOp = ILIT(199)
-tagOf_PrimOp ParOp = ILIT(200)
-tagOf_PrimOp ForkOp = ILIT(201)
-tagOf_PrimOp DelayOp = ILIT(202)
-tagOf_PrimOp WaitReadOp = ILIT(203)
-tagOf_PrimOp WaitWriteOp = ILIT(204)
-tagOf_PrimOp ParGlobalOp = ILIT(205)
-tagOf_PrimOp ParLocalOp = ILIT(206)
-tagOf_PrimOp ParAtOp = ILIT(207)
-tagOf_PrimOp ParAtAbsOp = ILIT(208)
-tagOf_PrimOp ParAtRelOp = ILIT(209)
-tagOf_PrimOp ParAtForNowOp = ILIT(210)
-tagOf_PrimOp CopyableOp = ILIT(211)
-tagOf_PrimOp NoFollowOp = ILIT(212)
-tagOf_PrimOp SameMVarOp = ILIT(213)
+tagOf_PrimOp (NewByteArrayOp StablePtrRep) = ILIT(130)
+tagOf_PrimOp SameMutableArrayOp = ILIT(131)
+tagOf_PrimOp SameMutableByteArrayOp = ILIT(132)
+tagOf_PrimOp ReadArrayOp = ILIT(133)
+tagOf_PrimOp WriteArrayOp = ILIT(134)
+tagOf_PrimOp IndexArrayOp = ILIT(135)
+tagOf_PrimOp (ReadByteArrayOp CharRep) = ILIT(136)
+tagOf_PrimOp (ReadByteArrayOp IntRep) = ILIT(137)
+tagOf_PrimOp (ReadByteArrayOp WordRep) = ILIT(138)
+tagOf_PrimOp (ReadByteArrayOp AddrRep) = ILIT(139)
+tagOf_PrimOp (ReadByteArrayOp FloatRep) = ILIT(140)
+tagOf_PrimOp (ReadByteArrayOp DoubleRep) = ILIT(141)
+tagOf_PrimOp (ReadByteArrayOp StablePtrRep) = ILIT(142)
+tagOf_PrimOp (ReadByteArrayOp Int64Rep) = ILIT(143)
+tagOf_PrimOp (ReadByteArrayOp Word64Rep) = ILIT(144)
+tagOf_PrimOp (WriteByteArrayOp CharRep) = ILIT(145)
+tagOf_PrimOp (WriteByteArrayOp AddrRep) = ILIT(146)
+tagOf_PrimOp (WriteByteArrayOp IntRep) = ILIT(147)
+tagOf_PrimOp (WriteByteArrayOp WordRep) = ILIT(148)
+tagOf_PrimOp (WriteByteArrayOp FloatRep) = ILIT(149)
+tagOf_PrimOp (WriteByteArrayOp DoubleRep) = ILIT(150)
+tagOf_PrimOp (WriteByteArrayOp StablePtrRep) = ILIT(151)
+tagOf_PrimOp (WriteByteArrayOp Int64Rep) = ILIT(152)
+tagOf_PrimOp (WriteByteArrayOp Word64Rep) = ILIT(153)
+tagOf_PrimOp (IndexByteArrayOp CharRep) = ILIT(154)
+tagOf_PrimOp (IndexByteArrayOp IntRep) = ILIT(155)
+tagOf_PrimOp (IndexByteArrayOp WordRep) = ILIT(156)
+tagOf_PrimOp (IndexByteArrayOp AddrRep) = ILIT(157)
+tagOf_PrimOp (IndexByteArrayOp FloatRep) = ILIT(158)
+tagOf_PrimOp (IndexByteArrayOp DoubleRep) = ILIT(159)
+tagOf_PrimOp (IndexByteArrayOp StablePtrRep) = ILIT(160)
+tagOf_PrimOp (IndexByteArrayOp Int64Rep) = ILIT(161)
+tagOf_PrimOp (IndexByteArrayOp Word64Rep) = ILIT(162)
+tagOf_PrimOp (IndexOffAddrOp CharRep) = ILIT(163)
+tagOf_PrimOp (IndexOffAddrOp IntRep) = ILIT(164)
+tagOf_PrimOp (IndexOffAddrOp WordRep) = ILIT(165)
+tagOf_PrimOp (IndexOffAddrOp AddrRep) = ILIT(166)
+tagOf_PrimOp (IndexOffAddrOp FloatRep) = ILIT(167)
+tagOf_PrimOp (IndexOffAddrOp DoubleRep) = ILIT(168)
+tagOf_PrimOp (IndexOffAddrOp StablePtrRep) = ILIT(169)
+tagOf_PrimOp (IndexOffAddrOp Int64Rep) = ILIT(170)
+tagOf_PrimOp (IndexOffAddrOp Word64Rep) = ILIT(171)
+tagOf_PrimOp (IndexOffForeignObjOp CharRep) = ILIT(172)
+tagOf_PrimOp (IndexOffForeignObjOp IntRep) = ILIT(173)
+tagOf_PrimOp (IndexOffForeignObjOp WordRep) = ILIT(174)
+tagOf_PrimOp (IndexOffForeignObjOp AddrRep) = ILIT(175)
+tagOf_PrimOp (IndexOffForeignObjOp FloatRep) = ILIT(176)
+tagOf_PrimOp (IndexOffForeignObjOp DoubleRep) = ILIT(177)
+tagOf_PrimOp (IndexOffForeignObjOp StablePtrRep) = ILIT(178)
+tagOf_PrimOp (IndexOffForeignObjOp Int64Rep) = ILIT(179)
+tagOf_PrimOp (IndexOffForeignObjOp Word64Rep) = ILIT(180)
+tagOf_PrimOp (WriteOffAddrOp CharRep) = ILIT(181)
+tagOf_PrimOp (WriteOffAddrOp IntRep) = ILIT(182)
+tagOf_PrimOp (WriteOffAddrOp WordRep) = ILIT(183)
+tagOf_PrimOp (WriteOffAddrOp AddrRep) = ILIT(184)
+tagOf_PrimOp (WriteOffAddrOp FloatRep) = ILIT(185)
+tagOf_PrimOp (WriteOffAddrOp DoubleRep) = ILIT(186)
+tagOf_PrimOp (WriteOffAddrOp StablePtrRep) = ILIT(187)
+tagOf_PrimOp (WriteOffAddrOp ForeignObjRep) = ILIT(188)
+tagOf_PrimOp (WriteOffAddrOp Int64Rep) = ILIT(189)
+tagOf_PrimOp (WriteOffAddrOp Word64Rep) = ILIT(190)
+tagOf_PrimOp UnsafeFreezeArrayOp = ILIT(191)
+tagOf_PrimOp UnsafeFreezeByteArrayOp = ILIT(192)
+tagOf_PrimOp SizeofByteArrayOp = ILIT(193)
+tagOf_PrimOp SizeofMutableByteArrayOp = ILIT(194)
+tagOf_PrimOp NewSynchVarOp = ILIT(195)
+tagOf_PrimOp TakeMVarOp = ILIT(196)
+tagOf_PrimOp PutMVarOp = ILIT(197)
+tagOf_PrimOp ReadIVarOp = ILIT(198)
+tagOf_PrimOp WriteIVarOp = ILIT(199)
+tagOf_PrimOp MakeForeignObjOp = ILIT(200)
+tagOf_PrimOp WriteForeignObjOp = ILIT(201)
+tagOf_PrimOp MakeStablePtrOp = ILIT(202)
+tagOf_PrimOp DeRefStablePtrOp = ILIT(203)
+tagOf_PrimOp (CCallOp _ _ _ _ _ _) = ILIT(204)
+tagOf_PrimOp ErrorIOPrimOp = ILIT(205)
+tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(206)
+tagOf_PrimOp SeqOp = ILIT(207)
+tagOf_PrimOp ParOp = ILIT(208)
+tagOf_PrimOp ForkOp = ILIT(209)
+tagOf_PrimOp DelayOp = ILIT(210)
+tagOf_PrimOp WaitReadOp = ILIT(211)
+tagOf_PrimOp WaitWriteOp = ILIT(212)
+tagOf_PrimOp ParGlobalOp = ILIT(213)
+tagOf_PrimOp ParLocalOp = ILIT(214)
+tagOf_PrimOp ParAtOp = ILIT(215)
+tagOf_PrimOp ParAtAbsOp = ILIT(216)
+tagOf_PrimOp ParAtRelOp = ILIT(217)
+tagOf_PrimOp ParAtForNowOp = ILIT(218)
+tagOf_PrimOp CopyableOp = ILIT(219)
+tagOf_PrimOp NoFollowOp = ILIT(220)
+tagOf_PrimOp SameMVarOp = ILIT(221)
tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match"
@@ -625,6 +636,7 @@ allThePrimOps
NewByteArrayOp AddrRep,
NewByteArrayOp FloatRep,
NewByteArrayOp DoubleRep,
+ NewByteArrayOp StablePtrRep,
SameMutableArrayOp,
SameMutableByteArrayOp,
ReadArrayOp,
@@ -636,6 +648,7 @@ allThePrimOps
ReadByteArrayOp AddrRep,
ReadByteArrayOp FloatRep,
ReadByteArrayOp DoubleRep,
+ ReadByteArrayOp StablePtrRep,
ReadByteArrayOp Int64Rep,
ReadByteArrayOp Word64Rep,
WriteByteArrayOp CharRep,
@@ -644,6 +657,7 @@ allThePrimOps
WriteByteArrayOp AddrRep,
WriteByteArrayOp FloatRep,
WriteByteArrayOp DoubleRep,
+ WriteByteArrayOp StablePtrRep,
WriteByteArrayOp Int64Rep,
WriteByteArrayOp Word64Rep,
IndexByteArrayOp CharRep,
@@ -652,6 +666,7 @@ allThePrimOps
IndexByteArrayOp AddrRep,
IndexByteArrayOp FloatRep,
IndexByteArrayOp DoubleRep,
+ IndexByteArrayOp StablePtrRep,
IndexByteArrayOp Int64Rep,
IndexByteArrayOp Word64Rep,
IndexOffAddrOp CharRep,
@@ -660,6 +675,7 @@ allThePrimOps
IndexOffAddrOp AddrRep,
IndexOffAddrOp FloatRep,
IndexOffAddrOp DoubleRep,
+ IndexOffAddrOp StablePtrRep,
IndexOffAddrOp Int64Rep,
IndexOffAddrOp Word64Rep,
IndexOffForeignObjOp CharRep,
@@ -668,6 +684,7 @@ allThePrimOps
IndexOffForeignObjOp WordRep,
IndexOffForeignObjOp FloatRep,
IndexOffForeignObjOp DoubleRep,
+ IndexOffForeignObjOp StablePtrRep,
IndexOffForeignObjOp Int64Rep,
IndexOffForeignObjOp Word64Rep,
WriteOffAddrOp CharRep,
@@ -676,6 +693,8 @@ allThePrimOps
WriteOffAddrOp AddrRep,
WriteOffAddrOp FloatRep,
WriteOffAddrOp DoubleRep,
+ WriteOffAddrOp StablePtrRep,
+ WriteOffAddrOp ForeignObjRep,
WriteOffAddrOp Int64Rep,
WriteOffAddrOp Word64Rep,
UnsafeFreezeArrayOp,
@@ -1121,18 +1140,23 @@ primOpInfo (ReadByteArrayOp kind)
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("read" ++ str ++ "Array#")
- relevant_tycon = assoc "primOpInfo" tbl kind
+ relevant_tycon = (assoc "primOpInfo{ReadByteArrayOp}" tbl kind)
+
+ (tycon_args, tvs)
+ | kind == StablePtrRep = ([s, betaTy], [s_tv, betaTyVar])
+ | otherwise = ([s], [s_tv])
in
- AlgResult op_str [s_tv]
+ AlgResult op_str tvs
[mkMutableByteArrayPrimTy s, intPrimTy, mkStatePrimTy s]
- relevant_tycon [s]
+ relevant_tycon tycon_args
where
- tbl = [ (CharRep, stateAndCharPrimTyCon),
- (IntRep, stateAndIntPrimTyCon),
- (WordRep, stateAndWordPrimTyCon),
- (AddrRep, stateAndAddrPrimTyCon),
- (FloatRep, stateAndFloatPrimTyCon),
- (DoubleRep, stateAndDoublePrimTyCon) ]
+ tbl = [ (CharRep, stateAndCharPrimTyCon),
+ (IntRep, stateAndIntPrimTyCon),
+ (WordRep, stateAndWordPrimTyCon),
+ (AddrRep, stateAndAddrPrimTyCon),
+ (FloatRep, stateAndFloatPrimTyCon),
+ (StablePtrRep, stateAndStablePtrPrimTyCon),
+ (DoubleRep, stateAndDoublePrimTyCon) ]
-- How come there's no Word byte arrays? ADR
@@ -1142,33 +1166,50 @@ primOpInfo (WriteByteArrayOp kind)
(str, prim_ty, _) = getPrimRepInfo kind
op_str = _PK_ ("write" ++ str ++ "Array#")
+
+ (the_prim_ty, tvs)
+ | kind == StablePtrRep = (mkStablePtrPrimTy betaTy, [s_tv, betaTyVar])
+ | otherwise = (prim_ty, [s_tv])
+
in
-- NB: *Prim*Result --
- PrimResult op_str [s_tv]
- [mkMutableByteArrayPrimTy s, intPrimTy, prim_ty, mkStatePrimTy s]
+ PrimResult op_str tvs
+ [mkMutableByteArrayPrimTy s, intPrimTy, the_prim_ty, mkStatePrimTy s]
statePrimTyCon VoidRep [s]
primOpInfo (IndexByteArrayOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "Array#")
+
+ (prim_tycon_args, tvs)
+ | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
+ | otherwise = ([],[])
in
-- NB: *Prim*Result --
- PrimResult op_str [] [byteArrayPrimTy, intPrimTy] prim_tycon kind []
+ PrimResult op_str tvs [byteArrayPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (IndexOffAddrOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffAddr#")
+
+ (prim_tycon_args, tvs)
+ | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
+ | otherwise = ([], [])
in
- PrimResult op_str [] [addrPrimTy, intPrimTy] prim_tycon kind []
+ PrimResult op_str tvs [addrPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (IndexOffForeignObjOp kind)
= let
(str, _, prim_tycon) = getPrimRepInfo kind
op_str = _PK_ ("index" ++ str ++ "OffForeignObj#")
+
+ (prim_tycon_args, tvs)
+ | kind == StablePtrRep = ([alphaTy], [alphaTyVar])
+ | otherwise = ([], [])
in
- PrimResult op_str [] [foreignObjPrimTy, intPrimTy] prim_tycon kind []
+ PrimResult op_str tvs [foreignObjPrimTy, intPrimTy] prim_tycon kind prim_tycon_args
primOpInfo (WriteOffAddrOp kind)
= let
@@ -1964,8 +2005,8 @@ pprPrimOp (CCallOp fun is_casm may_gc cconv arg_tys res_ty)
ppr_fun =
case fun of
- Nothing -> ptext SLIT("<dynamic>")
- Just fn -> ptext fn
+ Right _ -> ptext SLIT("<dynamic>")
+ Left fn -> ptext fn
in
hcat [ ifPprDebug callconv
diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs
index 8baa7f3076a5d87abcf3160231a78dc20cbd8eaf..69b659257cd66d292b9642ca8a02747bb2643b35 100644
--- a/ghc/compiler/prelude/TysPrim.lhs
+++ b/ghc/compiler/prelude/TysPrim.lhs
@@ -87,6 +87,9 @@ getPrimRepInfo FloatRep = ("Float", floatPrimTy, floatPrimTyCon)
getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon)
getPrimRepInfo Int64Rep = ("Int64", int64PrimTy, int64PrimTyCon)
getPrimRepInfo Word64Rep = ("Word64", word64PrimTy, word64PrimTyCon)
+getPrimRepInfo StablePtrRep = ("StablePtr", mkStablePtrPrimTy alphaTy, stablePtrPrimTyCon)
+getPrimRepInfo ForeignObjRep = ("ForeignObj", foreignObjPrimTy, foreignObjPrimTyCon)
+
\end{code}
%************************************************************************
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 77d01ff70b835d7c11c123558dba1fce6f68e366..de10ed9b1030771a8017701e74390c14ea987b45 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -30,6 +30,8 @@ import UniqSupply ( UniqSupply, UniqSM,
returnUs, thenUs, initUs,
mapUs, getUnique
)
+import PrimOp ( PrimOp(..) )
+
import Outputable ( panic )
isLeakFreeType x y = False -- safe option; ToDo
@@ -241,10 +243,17 @@ coreExprToStg env (Con con args)
returnUs (StgCon con stg_atoms bOGUS_LVs)
coreExprToStg env (Prim op args)
- = let
+ = mkPrimOpUnique op `thenUs` \ op' ->
+ let
(types, stg_atoms) = coreArgsToStg env args
in
- returnUs (StgPrim op stg_atoms bOGUS_LVs)
+ returnUs (StgPrim op' stg_atoms bOGUS_LVs)
+ where
+ mkPrimOpUnique (CCallOp (Right _) a b c d e) =
+ getUnique `thenUs` \ u ->
+ returnUs (CCallOp (Right u) a b c d e)
+ mkPrimOpUnique op = returnUs op
+
\end{code}
%************************************************************************
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index d8088bbad18b2f3a7b114ab65f133e48a753ed36..9264fb52b13b3eeb40352015b89b5e07597b3e85 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -356,7 +356,7 @@ tcCorePrim (UfOtherOp op)
tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
= mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
tcHsType res_ty `thenTc` \ res_ty' ->
- returnTc (CCallOp (Just str) casm gc cCallConv arg_tys' res_ty')
+ returnTc (CCallOp (Left str) casm gc cCallConv arg_tys' res_ty')
\end{code}
\begin{code}