[project @ 1998-10-21 11:28:00 by sof]

- added primops for read&writing StablePtrs to ByteArrays, Adds and FOs
- egcs crashes in odd ways when encountering the typedefs we need to
  produce when compiling 'foreign import dynamic's. To workaround the
  problem, kludgily add a CCallTypedef constructor to AbsCSyn.AbstractC
  which the flattener will produce (at the toplevel) when encountering
  CCallOps inside COptStmts.
- augmented PrimOp.CCallOp to carry a unique when it represents a
  'foreign import dynamic' call. The CoreToStg pass ensures that these
  uniques are exactly that. They're used to eventuall generate (unique)
  typedef names.

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index c8eaaa8..05972fa 100644 (file)
--- 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 940e1d5..a8f9756 100644 (file)
--- 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 fe78a3d..ce7180e 100644 (file)
--- 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 73630c6..511c288 100644 (file)
--- 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 2a855af..f495cd2 100644 (file)
--- 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 c23c743..9279242 100644 (file)
--- 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 aa41673..71ad733 100644 (file)
--- 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 8baa7f3..69b6592 100644 (file)
--- 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 77d01ff..de10ed9 100644 (file)
--- 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 d8088bb..9264fb5 100644 (file)
--- 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}