From b0624daa9057eec25ddf35a9ed3c771b9c5d9c75 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 30 Jun 2000 13:11:08 +0000 Subject: [PATCH] [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. --- ghc/compiler/absCSyn/AbsCUtils.lhs | 14 +++++++------- ghc/compiler/absCSyn/PprAbsC.lhs | 28 ++++++++-------------------- ghc/compiler/deSugar/DsForeign.lhs | 11 +++++------ ghc/compiler/prelude/PrimOp.lhs | 26 ++++++++++++++++++++++++-- ghc/compiler/stgSyn/CoreToStg.lhs | 11 +++++++---- 5 files changed, 51 insertions(+), 39 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 07a91bf..8e4d758 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -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) -> diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index f3dd000..667d1bb 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -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..] diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index b0d3fb0..3614d8d 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -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) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index a55af16..34d49c7 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -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} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index fc0a8d5..44cff7e 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -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' -> -- 1.7.10.4