Commit 0fffbea8 authored by sof's avatar sof
Browse files

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

Fixes to support .hi unfoldings containing "_ccall_ dynamic"s
parent 56c77af5
......@@ -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
......
......@@ -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
......
......@@ -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)
]
......
......@@ -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)] }
......
......@@ -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}
%*********************************************************
......
......@@ -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 ->
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment