From 6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09 Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Mon, 4 Jan 2010 03:15:06 +0000 Subject: [PATCH] Refactor PackageTarget back into StaticTarget --- compiler/codeGen/CgForeignCall.hs | 9 +------ compiler/codeGen/StgCmmForeign.hs | 16 +++++++++---- compiler/coreSyn/MkExternalCore.lhs | 2 +- compiler/deSugar/DsCCall.lhs | 2 +- compiler/deSugar/DsMeta.hs | 4 ++-- compiler/ghci/ByteCodeGen.lhs | 15 +----------- compiler/hsSyn/HsDecls.lhs | 4 +--- compiler/parser/ParserCore.y | 2 +- compiler/parser/RdrHsSyn.lhs | 4 ++-- compiler/prelude/ForeignCall.lhs | 44 +++++++++++++++++------------------ compiler/rename/RnSource.lhs | 4 ++-- compiler/stgSyn/CoreToStg.lhs | 2 +- compiler/typecheck/TcForeign.lhs | 6 +---- 13 files changed, 46 insertions(+), 68 deletions(-) diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 879d043..901dd96 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -78,16 +78,9 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live where (call_args, cmm_target) = case target of - - -- A target label known to be in the current package. - StaticTarget lbl - -> ( args - , CmmLit (CmmLabel - (mkForeignLabel lbl call_size ForeignLabelInThisPackage IsFunction))) - -- If the packageId is Nothing then the label is taken to be in the -- package currently being compiled. - PackageTarget lbl mPkgId + StaticTarget lbl mPkgId -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index bda9e0f..b98da50 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -56,11 +56,17 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a = do { cmm_args <- getFCallArgs stg_args ; let ((call_args, arg_hints), cmm_target) = case target of - StaticTarget lbl -> - (unzip cmm_args, - CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args) - ForeignLabelInThisPackage IsFunction))) - DynamicTarget -> case cmm_args of + StaticTarget lbl mPkgId + -> let labelSource + = case mPkgId of + Nothing -> ForeignLabelInThisPackage + Just pkgId -> ForeignLabelInPackage pkgId + size = call_size cmm_args + in ( unzip cmm_args + , CmmLit (CmmLabel + (mkForeignLabel lbl size labelSource IsFunction))) + + DynamicTarget -> case cmm_args of (fn,_):rest -> (unzip rest, fn) [] -> panic "cgForeignCall []" fc = ForeignConvention cconv arg_hints result_hints diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 3eb9cd9..eae4b93 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -129,7 +129,7 @@ make_exp (Var v) = do isLocal <- isALocal vName return $ case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm) callconv _)) + FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _)) -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v)) FCallId (CCall (CCallSpec DynamicTarget callconv _)) -> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v)) diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 0dd29c9..f46d99e 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -91,7 +91,7 @@ dsCCall lbl args may_gc result_ty (ccall_result_ty, res_wrapper) <- boxResult result_ty uniq <- newUnique let - target = StaticTarget lbl + target = StaticTarget lbl Nothing the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index c2d83d6..e95df4d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -338,10 +338,10 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs) conv_cimportspec CWrapper = return "wrapper" static = case cis of - CFunction (StaticTarget _) -> "static " + CFunction (StaticTarget _ _) -> "static " _ -> "" repForD decl = notHandled "Foreign declaration" (ppr decl) diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 99e896c..5d1bd27 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -1029,20 +1029,7 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") - PackageTarget target _ - -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) - return (True, res) - where - stdcall_adj_target -#ifdef mingw32_TARGET_OS - | StdCallConv <- cconv - = let size = fromIntegral a_reps_sizeW * wORD_SIZE in - mkFastString (unpackFS target ++ '@':show size) -#endif - | otherwise - = target - - StaticTarget target + StaticTarget target _ -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target) return (True, res) where diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 0312dcb..607b319 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -940,9 +940,7 @@ instance Outputable ForeignImport where pprCEntity (CLabel lbl) = ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget lbl)) = - ptext (sLit "static") <+> pp_hdr <+> ppr lbl - pprCEntity (CFunction (PackageTarget lbl _)) = + pprCEntity (CFunction (StaticTarget lbl _)) = ptext (sLit "static") <+> pp_hdr <+> ppr lbl pprCEntity (CFunction (DynamicTarget)) = ptext (sLit "dynamic") diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index f43e225..0289cfc 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -277,7 +277,7 @@ exp :: { IfaceExpr } -- "InlineMe" -> IfaceNote IfaceInlineMe $3 -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall - (CCallSpec (StaticTarget (mkFastString $2)) + (CCallSpec (StaticTarget (mkFastString $2) Nothing) CCallConv (PlaySafe False))) $3 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index f230187..d18b8d8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -985,7 +985,7 @@ mkImport :: CCallConv -> P (HsDecl RdrName) mkImport cconv safety (L loc entity, v, ty) | cconv == PrimCallConv = do - let funcTarget = CFunction (PackageTarget entity Nothing) + let funcTarget = CFunction (StaticTarget entity Nothing) importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) @@ -1023,7 +1023,7 @@ parseCImport cconv safety nm str = id_char c = isAlphaNum c || c == '_' cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ ((\c -> CFunction (PackageTarget c Nothing)) <$> cid) + +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid) where cid = return nm +++ (do c <- satisfy (\c -> isAlpha c || c == '_') diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 578ab3c..4423d03 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -103,17 +103,23 @@ The call target: \begin{code} --- | How to call a particular function in C land. +-- | How to call a particular function in C-land. data CCallTarget - -- An "unboxed" ccall# to named function - = StaticTarget CLabelString + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + CLabelString -- C-land name of label. + + (Maybe PackageId) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. -- The first argument of the import is the name of a function pointer (an Addr#). -- Used when importing a label as "foreign import ccall "dynamic" ..." | DynamicTarget - - -- An "unboxed" ccall# to a named function from a particular package. - | PackageTarget CLabelString (Maybe PackageId) deriving( Eq ) {-! derive: Binary !-} @@ -197,17 +203,14 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun DynamicTarget - = text "__dyn_ccall" <> gc_suf <+> text "\"\"" - - ppr_fun (PackageTarget fn Nothing) + ppr_fun (StaticTarget fn Nothing) = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn - ppr_fun (PackageTarget fn (Just pkgId)) + ppr_fun (StaticTarget fn (Just pkgId)) = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn - ppr_fun (StaticTarget fn) - = text "__ccall" <> gc_suf <+> pprCLabelString fn + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" \end{code} @@ -257,24 +260,19 @@ instance Binary CCallSpec where return (CCallSpec aa ab ac) instance Binary CCallTarget where - put_ bh (StaticTarget aa) = do + put_ bh (StaticTarget aa ab) = do putByte bh 0 put_ bh aa + put_ bh ab put_ bh DynamicTarget = do putByte bh 1 - put_ bh (PackageTarget aa ab) = do - putByte bh 2 - put_ bh aa - put_ bh ab get bh = do h <- getByte bh case h of 0 -> do aa <- get bh - return (StaticTarget aa) - 1 -> do return DynamicTarget - _ -> do aa <- get bh - ab <- get bh - return (PackageTarget aa ab) + ab <- get bh + return (StaticTarget aa ab) + _ -> do return DynamicTarget instance Binary CCallConv where put_ bh CCallConv = do diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2911ce0..bfecfd6 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -412,8 +412,8 @@ patchCImportSpec packageId spec patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget patchCCallTarget packageId callTarget = case callTarget of - PackageTarget label Nothing - -> PackageTarget label (Just packageId) + StaticTarget label Nothing + -> StaticTarget label (Just packageId) _ -> callTarget diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index f49f092..edda603 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -534,7 +534,7 @@ coreToStgApp _ f args = do StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (PackageTarget lbl (Just pkgId)) PrimCallConv _)) + FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _)) -> ASSERT( saturated ) StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 1901357..fdb7ce5 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -162,11 +162,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar -- This makes a convenient place to check -- that the C identifier is valid for C checkCTarget :: CCallTarget -> TcM () -checkCTarget (StaticTarget str) = do - checkCg checkCOrAsmOrDotNetOrInterp - check (isCLabelString str) (badCName str) - -checkCTarget (PackageTarget str _) = do +checkCTarget (StaticTarget str _) = do checkCg checkCOrAsmOrDotNetOrInterp check (isCLabelString str) (badCName str) -- 1.7.10.4