[project @ 1999-01-14 19:53:57 by sof]

Fixes to support .hi unfoldings containing "_ccall_ dynamic"s

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index e887f7e..b5d80e8 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -58,6 +58,7 @@ data UfCon name = UfDefault
                | UfLitLitCon FAST_STRING (HsType name)
                | UfPrimOp name
                | UfCCallOp FAST_STRING    -- callee
+                           Bool           -- True => dynamic (first arg is fun. pointer)
                            Bool           -- True <=> casm, rather than ccall
                            Bool           -- True <=> might cause GC
 
@@ -115,10 +116,11 @@ instance Outputable name => Outputable (UfCon name) where
     ppr UfDefault      = text "DEFAULT"
     ppr (UfDataCon d)  = ppr d
     ppr (UfPrimOp p)   = ppr p
-    ppr (UfCCallOp str is_casm can_gc)
+    ppr (UfCCallOp str is_dyn is_casm can_gc)
       =        hcat [before, ptext str, after]
       where
-           before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+           before = (if is_dyn then ptext SLIT("_dyn_") else empty) <>
+                    ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
            after  = if is_casm then text "'' " else space
 
 instance Outputable name => Outputable (UfBinder name) where

diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 4a6e215..8dd4415 100644 (file)
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -2025,22 +2025,28 @@ pprPrimOp (CCallOp fun is_casm may_gc cconv)
         callconv = text "{-" <> pprCallConv cconv <> text "-}"
 
        before
-         | is_casm && may_gc = "__casm_GC ``"
-         | is_casm           = "__casm ``"
-         | may_gc            = "__ccall_GC "
-         | otherwise         = "__ccall "
+         | is_casm && may_gc = "casm_GC ``"
+         | is_casm           = "casm ``"
+         | may_gc            = "ccall_GC "
+         | otherwise         = "ccall "
 
        after
          | is_casm   = text "''"
          | otherwise = empty
+         
+       ppr_dyn =
+         case fun of
+           Right _ -> text "dyn_"
+           _       -> empty
 
        ppr_fun =
         case fun of
-          Right _ -> ptext SLIT("<dynamic>")
+          Right _ -> text "\"\""
           Left fn -> ptext fn
         
     in
     hcat [ ifPprDebug callconv
+        , text "__", ppr_dyn
          , text before , ppr_fun , after]
 
 pprPrimOp other_op

diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 4699de9..70d6b6b 100644 (file)
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -127,7 +127,7 @@ data IfaceToken
   | ITletrec 
   | ITcoerce
   | ITinline
-  | ITccall (Bool,Bool)        -- (is_casm, may_gc)
+  | ITccall (Bool,Bool,Bool)   -- (is_dyn, is_casm, may_gc)
   | ITdefaultbranch
   | ITbottom
   | ITinteger_lit 
@@ -656,10 +656,13 @@ ifaceKeywordsFM = listToUFM $
         ("__Unot",             ITunfold IMustNotBeINLINEd),
         ("__Ux",               ITunfold IAmALoopBreaker),
        
-        ("__ccall",            ITccall (False, False)),
-        ("__ccall_GC",         ITccall (False, True)),
-        ("__casm",             ITccall (True,  False)),
-        ("__casm_GC",          ITccall (True,  True)),
+        ("__ccall",            ITccall (False, False, False)),
+        ("__dyn_ccall",                ITccall (True,  False, False)),
+        ("__dyn_ccall_GC",     ITccall (True,  False, True)),
+        ("__casm",             ITccall (False, True,  False)),
+        ("__dyn_casm",         ITccall (True,  True,  False)),
+        ("__casm_GC",          ITccall (False, True,  True)),
+        ("__dyn_casm_GC",      ITccall (True,  True,  True)),
 
         ("/\\",                        ITbiglam)
        ]

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 30c1478..e548c1e 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -572,9 +572,9 @@ con_or_primop   :: { UfCon RdrName }
 con_or_primop   : qdata_name                    { UfDataCon $1 }
                 | qvar_name                    { UfPrimOp $1 }
                 | '__ccall' ccall_string      { let
-                                               (is_casm, may_gc) = $1
+                                               (is_dyn, is_casm, may_gc) = $1
                                                in
-                                               UfCCallOp $2 is_casm may_gc
+                                               UfCCallOp $2 is_dyn is_casm may_gc
                                                }
 
 rec_binds      :: { [(UfBinder RdrName, UfExpr RdrName)] }

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 34966a7..01091ca 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -759,8 +759,8 @@ rnUfCon (UfPrimOp op)
   = lookupOccRn op             `thenRn` \ op' ->
     returnRn (UfPrimOp op')
 
-rnUfCon (UfCCallOp str casm gc)
-  = returnRn (UfCCallOp str casm gc)
+rnUfCon (UfCCallOp str is_dyn casm gc)
+  = returnRn (UfCCallOp str is_dyn casm gc)
 \end{code}
 
 %*********************************************************

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index db7ea31..40cc5df 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -306,8 +306,12 @@ tcUfCon (UfPrimOp name)
        Just op -> returnTc (PrimOp op)
        Nothing -> failWithTc (badPrimOp name)
 
-tcUfCon (UfCCallOp str casm gc)
-  = returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
+tcUfCon (UfCCallOp str is_dyn casm gc)
+  = case is_dyn of
+       True  -> 
+          tcGetUnique `thenNF_Tc` \ u ->
+         returnTc (PrimOp (CCallOp (Right u) casm gc cCallConv))
+       False -> returnTc (PrimOp (CCallOp (Left str) casm gc cCallConv))
 
 tcUfDataCon name
   = tcVar name         `thenTc` \ con_id ->