Commit b0624daa authored by simonpj's avatar simonpj
Browse files

[project @ 2000-06-30 13:11:07 by simonpj]

In a CCall, a DynamicTarget has a unique that is
used only to generate a uniquely-named typedef.
It should not be used when comparing CCalls (e.g.
when seeing if interface files have changed).
So the main change in this commit is to fix the Eq
instance for PrimOp.CCallTarget, but I took the
opportunity to clean up the CCallTarget interface
a little.
parent 9282daea
......@@ -29,7 +29,7 @@ import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_OutputLanguage, opt_EmitCExternDecls )
import Maybes ( maybeToBool )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
import Panic ( panic )
infixr 9 `thenFlt`
......@@ -331,16 +331,16 @@ flatAbsC (CSwitch discrim alts deflt)
= flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs)
flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
| isCandidate && opt_OutputLanguage == Just "C" -- Urgh
= returnFlt (stmt, tdef)
| otherwise
= returnFlt (stmt, AbsCNop)
where
(isCandidate, isDyn) =
case ccall of
CCall (DynamicTarget _) _ _ _ -> (True, True)
CCall (StaticTarget _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
is_dynamic = isDynamicTarget target
tdef = CCallTypedef isDyn ccall results args
tdef = CCallTypedef is_dynamic ccall results args
flatAbsC stmt@(CSimultaneous abs_c)
= flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
......
......@@ -46,7 +46,7 @@ import Name ( NamedThing(..) )
import DataCon ( DataCon{-instance NamedThing-}, dataConWrapId )
import Maybes ( maybeToBool, catMaybes )
import PrimOp ( primOpNeedsWrapper, pprPrimOp, pprCCallOp,
PrimOp(..), CCall(..), CCallTarget(..) )
PrimOp(..), CCall(..), CCallTarget(..), isDynamicTarget )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
import SMRep ( pprSMRep )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
......@@ -821,42 +821,30 @@ pprCCall call@(CCall op_str is_asm may_gc cconv) args results vol_regs
[amode] -> text (showPrimRep (getAmodeRep amode))
_ -> panic "pprCCall: ccall_res_ty"
ccall_fun_ty =
ptext SLIT("_ccall_fun_ty") <>
case op_str of
DynamicTarget u -> ppr u
_ -> empty
(declare_local_vars, local_vars, assign_results)
= ppr_casm_results non_void_results
(StaticTarget asm_str) = op_str
is_dynamic =
case op_str of
StaticTarget _ -> False
DynamicTarget _ -> True
casm_str = if is_asm then _UNPK_ asm_str else ccall_str
StaticTarget asm_str = op_str -- Must be static if it's a casm
-- Remainder only used for ccall
fun_name
| is_dynamic = parens (parens (ccall_fun_ty) <> text "%0")
| otherwise = ptext asm_str
fun_name = case op_str of
DynamicTarget u -> parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr u) <> text "%0")
StaticTarget st -> pprCLabelString st
ccall_str = showSDoc
(hcat [
if null non_void_results
then empty
else text "%r = ",
lparen, fun_name, lparen,
lparen, parens fun_name, lparen,
hcat (punctuate comma ccall_fun_args),
text "));"
])
ccall_fun_args
| is_dynamic = tail ccall_args
| otherwise = ccall_args
ccall_fun_args | isDynamicTarget op_str = tail ccall_args
| otherwise = ccall_args
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
......
......@@ -38,7 +38,7 @@ import Type ( unUsgTy, repType,
mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
)
import PprType ( {- instance Outputable Type -} )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) )
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), dynamicTarget )
import Var ( TyVar )
import TysPrim ( realWorldStatePrimTy, addrPrimTy )
import TysWiredIn ( unitTy, addrTy, stablePtrTyCon,
......@@ -141,14 +141,13 @@ dsFImport fn_id ty may_not_gc ext_name cconv
mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) ->
boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
(case ext_name of
Dynamic -> getUniqueDs `thenDs` \ u ->
returnDs (DynamicTarget u)
ExtName fs _ -> returnDs (StaticTarget fs)) `thenDs` \ lbl ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
let
lbl = case ext_name of
Dynamic -> dynamicTarget
ExtName fs _ -> StaticTarget fs
-- Build the worker
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
......
......@@ -19,7 +19,8 @@ module PrimOp (
pprPrimOp,
CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp
CCall(..), CCallTarget(..), ccallMayGC, ccallIsCasm, pprCCallOp,
isDynamicTarget, dynamicTarget, setCCallUnique
) where
#include "HsVersions.h"
......@@ -2418,13 +2419,34 @@ data CCallTarget
-- (unique is used to generate a 'typedef' to cast
-- the function pointer if compiling the ccall# down to
-- .hc code - can't do this inline for tedious reasons.)
deriving( Eq )
instance Eq CCallTarget where
(StaticTarget l1) == (StaticTarget l2) = l1 == l2
(DynamicTarget _) == (DynamicTarget _) = True
-- Ignore the arbitrary unique; this is important when comparing
-- a dynamic ccall read from an interface file A.hi with the
-- one constructed from A.hs, when deciding whether the interface
-- has changed
t1 == t2 = False
ccallMayGC :: CCall -> Bool
ccallMayGC (CCall _ _ may_gc _) = may_gc
ccallIsCasm :: CCall -> Bool
ccallIsCasm (CCall _ c_asm _ _) = c_asm
isDynamicTarget (DynamicTarget _) = True
isDynamicTarget (StaticTarget _) = False
dynamicTarget :: CCallTarget
dynamicTarget = DynamicTarget (panic "Unique in DynamicTarget not yet set")
-- The unique is really only to do with code generation, so it
-- is only set in CoreToStg; before then it's just an error message
setCCallUnique :: CCall -> Unique -> CCall
setCCallUnique (CCall (DynamicTarget _) is_asm may_gc cconv) uniq
= CCall (DynamicTarget uniq) is_asm may_gc cconv
setCCallUnique ccall uniq = ccall
\end{code}
\begin{code}
......
......@@ -33,7 +33,7 @@ import Demand ( Demand, isStrict, wwStrict, wwLazy )
import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
import Literal ( Literal(..) )
import VarEnv
import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
import PrimOp ( PrimOp(..), setCCallUnique, primOpUsg )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
splitRepFunTys, mkFunTys
......@@ -657,11 +657,14 @@ mkStgApp env fn args ty
-> saturate fn_alias args ty $ \ args' ty' ->
returnUs (StgConApp dc args')
PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
PrimOpId (CCallOp ccall)
-- Sigh...make a guaranteed unique name for a dynamic ccall
-- Done here, not earlier, because it's a code-gen thing
-> saturate fn_alias args ty $ \ args' ty' ->
getUniqueUs `thenUs` \ u ->
returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
returnUs (StgPrimApp (CCallOp ccall') args' ty')
where
ccall' = setCCallUnique ccall (idUnique fn)
-- The particular unique doesn't matter
PrimOpId op
-> saturate fn_alias args ty $ \ args' ty' ->
......
Markdown is supported
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