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

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

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

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

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)
        ]

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)] }

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}
 
 %*********************************************************

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 ->