From 0fffbea841d9647388a7b845808a9757782da663 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Thu, 14 Jan 1999 19:54:05 +0000
Subject: [PATCH] [project @ 1999-01-14 19:53:57 by sof] Fixes to support .hi
unfoldings containing "_ccall_ dynamic"s
---
ghc/compiler/hsSyn/HsCore.lhs | 6 ++++--
ghc/compiler/prelude/PrimOp.lhs | 16 +++++++++++-----
ghc/compiler/reader/Lex.lhs | 13 ++++++++-----
ghc/compiler/rename/ParseIface.y | 4 ++--
ghc/compiler/rename/RnSource.lhs | 4 ++--
ghc/compiler/typecheck/TcIfaceSig.lhs | 8 ++++++--
6 files changed, 33 insertions(+), 18 deletions(-)
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index e887f7e4b854..b5d80e80dcdd 100644
--- 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 4a6e215de98b..8dd4415c2a06 100644
--- 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 4699de9869f9..70d6b6b0a89c 100644
--- 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 30c1478f264e..e548c1ee3a03 100644
--- 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 34966a75e7bc..01091ca6a4f8 100644
--- 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 db7ea310d6d9..40cc5dfc86bc 100644
--- 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 ->
--
GitLab