From 909691a910d99495baf396fca3ab7e82f2e2eb51 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 26 Jun 2009 09:54:21 +0000 Subject: [PATCH] Fix #3319, and do various tidyups at the same time - converting a THSyn FFI declaration to HsDecl was broken; fixed - pretty-printing of FFI declarations was variously bogus; fixed - there was an unused "library" field in CImport; removed --- compiler/deSugar/DsForeign.lhs | 2 +- compiler/deSugar/DsMeta.hs | 3 +-- compiler/hsSyn/Convert.lhs | 43 ++++++++++++++++++++---------- compiler/hsSyn/HsDecls.lhs | 24 +++++++---------- compiler/parser/RdrHsSyn.lhs | 54 +++++++++++++++++--------------------- compiler/typecheck/TcForeign.lhs | 6 ++--- 6 files changed, 68 insertions(+), 64 deletions(-) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 9dea2ad..9127676 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -124,7 +124,7 @@ because it exposes the boxing to the call site. dsFImport :: Id -> ForeignImport -> DsM ([Binding], SDoc, SDoc) -dsFImport id (CImport cconv safety _ _ spec) = do +dsFImport id (CImport cconv safety _ spec) = do (ids, h, c) <- dsCImport id spec cconv safety return (ids, h, c) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2b982b3..2de2cae 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -333,7 +333,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) +repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc @@ -341,7 +341,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) cis' <- conv_cimportspec cis MkC str <- coreStringLit $ static ++ unpackFS ch ++ " " - ++ unpackFS cn ++ " " ++ cis' dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index b4d897d..31a0bca 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -319,7 +319,7 @@ cvtForD (ImportF callconv safety from nm ty) | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis + ; let i = CImport (cvt_conv callconv) safety' c_header cis ; return $ ForeignImport nm' ty' i } | otherwise @@ -349,26 +349,41 @@ parse_ccall_impent nm s Just ts -> parse_ccall_impent_static nm ts Nothing -> Nothing +-- XXX we should be sharing code with RdrHsSyn.parseCImport parse_ccall_impent_static :: String -> [String] -> Maybe (FastString, CImportSpec) parse_ccall_impent_static nm ts - = let ts' = case ts of - [ "&", cid] -> [ cid] - [fname, "&" ] -> [fname ] - [fname, "&", cid] -> [fname, cid] - _ -> ts - in case ts' of - [ cid] | is_cid cid -> Just (nilFS, mk_cid cid) - [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid) - [ ] -> Just (nilFS, mk_cid nm) - [fname ] -> Just (mkFastString fname, mk_cid nm) - _ -> Nothing + = case ts of + [ ] -> mkFun nilFS nm + [ "&", cid] -> mkLbl nilFS cid + [fname, "&" ] -> mkLbl (mkFastString fname) nm + [fname, "&", cid] -> mkLbl (mkFastString fname) cid + [ "&" ] -> mkLbl nilFS nm + [fname, cid] -> mkFun (mkFastString fname) cid + [ cid] + | is_cid cid -> mkFun nilFS cid + | otherwise -> mkFun (mkFastString cid) nm + -- tricky case when there's a single string: "foo.h" is a header, + -- but "foo" is a C identifier, and we tell the difference by + -- checking for a valid C identifier (see is_cid below). + _anything_else -> Nothing + where is_cid :: String -> Bool is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_') - mk_cid :: String -> CImportSpec - mk_cid = CFunction . StaticTarget . mkFastString + mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec) + mkLbl fname lbl = Just (fname, CLabel (mkFastString lbl)) + + mkFun :: FastString -> String -> Maybe (FastString, CImportSpec) + mkFun fname lbl = Just (fname, CFunction (StaticTarget (mkFastString lbl))) + +-- This code is tokenising something like "foo.h &bar", eg. +-- "" -> Just [] +-- "foo.h" -> Just ["foo.h"] +-- "foo.h &bar" -> Just ["foo.h","&","bar"] +-- "&" -> Just ["&"] +-- Nothing is returned for a parse error. lex_ccall_impent :: String -> Maybe [String] lex_ccall_impent "" = Just [] lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 832f616..83bd6d5 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -904,7 +904,6 @@ data ForeignImport = -- import of a C entity CImport CCallConv -- ccall or stdcall Safety -- safe or unsafe FastString -- name of C header - FastString -- name of library object CImportSpec -- details of the C entity -- import of a .NET function @@ -944,22 +943,19 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where instance Outputable ForeignImport where ppr (DNImport spec) = ptext (sLit "dotnet") <+> ppr spec - ppr (CImport cconv safety header lib spec) = + ppr (CImport cconv safety header spec) = ppr cconv <+> ppr safety <+> - char '"' <> pprCEntity header lib spec <> char '"' + char '"' <> pprCEntity spec <> char '"' where - pprCEntity header lib (CLabel lbl) = - ptext (sLit "static") <+> ftext header <+> char '&' <> - pprLib lib <> ppr lbl - pprCEntity header lib (CFunction (StaticTarget lbl)) = - ptext (sLit "static") <+> ftext header <+> char '&' <> - pprLib lib <> ppr lbl - pprCEntity _ _ (CFunction (DynamicTarget)) = + pp_hdr = if nullFS header then empty else ftext header + + pprCEntity (CLabel lbl) = + ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget lbl)) = + ptext (sLit "static") <+> pp_hdr <+> ppr lbl + pprCEntity (CFunction (DynamicTarget)) = ptext (sLit "dynamic") - pprCEntity _ _ (CWrapper) = ptext (sLit "wrapper") - -- - pprLib lib | nullFS lib = empty - | otherwise = char '[' <> ppr lib <> char ']' + pprCEntity (CWrapper) = ptext (sLit "wrapper") instance Outputable ForeignExport where ppr (CExport (CExportStatic lbl cconv)) = diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index c1c5972..bd8299b 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -960,11 +960,11 @@ mkImport :: CallConv mkImport (CCall cconv) safety (entity, v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget (unLoc entity)) - importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget - return (ForD (ForeignImport v ty importSpec)) -mkImport (CCall cconv) safety (entity, v, ty) = do - importSpec <- parseCImport entity cconv safety v + importSpec = CImport PrimCallConv safety nilFS funcTarget return (ForD (ForeignImport v ty importSpec)) + | otherwise = do + importSpec <- parseCImport entity cconv safety v + return (ForD (ForeignImport v ty importSpec)) mkImport (DNCall ) _ (entity, v, ty) = do spec <- parseDImport entity return $ ForD (ForeignImport v ty (DNImport spec)) @@ -980,9 +980,9 @@ parseCImport :: Located FastString parseCImport (L loc entity) cconv safety v -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak | entity == fsLit "dynamic" = - return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) + return $ CImport cconv safety nilFS (CFunction DynamicTarget) | entity == fsLit "wrapper" = - return $ CImport cconv safety nilFS nilFS CWrapper + return $ CImport cconv safety nilFS CWrapper | otherwise = parse0 (unpackFS entity) where -- using the static keyword? @@ -990,41 +990,35 @@ parseCImport (L loc entity) cconv safety v parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest parse0 rest = parse1 rest -- check for header file name - parse1 "" = parse4 "" nilFS False nilFS + parse1 "" = parse4 "" nilFS False parse1 (' ':rest) = parse1 rest parse1 str@('&':_ ) = parse2 str nilFS - parse1 str@('[':_ ) = parse3 str nilFS False parse1 str | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) - | otherwise = parse4 str nilFS False nilFS + | otherwise = parse4 str nilFS False where - (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + (first, rest) = break (\c -> c == ' ' || c == '&') str -- check for address operator (indicating a label import) - parse2 "" header = parse4 "" header False nilFS + parse2 "" header = parse4 "" header False parse2 (' ':rest) header = parse2 rest header - parse2 ('&':rest) header = parse3 rest header True - parse2 str@('[':_ ) header = parse3 str header False - parse2 str header = parse4 str header False nilFS - -- check for library object name - parse3 (' ':rest) header isLbl = parse3 rest header isLbl - parse3 ('[':rest) header isLbl = - case break (== ']') rest of - (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) - _ -> parseError loc "Missing ']' in entity" - parse3 str header isLbl = parse4 str header isLbl nilFS + parse2 ('&':rest) header = parse3 rest header + parse2 str header = parse4 str header False + -- eat spaces after '&' + parse3 (' ':rest) header = parse3 rest header + parse3 str header = parse4 str header True -- check for name of C function - parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib - parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib - parse4 str header isLbl lib - | all (== ' ') rest = build (mkFastString first) header isLbl lib - | otherwise = parseError loc "Malformed entity string" + parse4 "" header isLbl = build (mkExtName (unLoc v)) header isLbl + parse4 (' ':rest) header isLbl = parse4 rest header isLbl + parse4 str header isLbl + | all (== ' ') rest = build (mkFastString first) header isLbl + | otherwise = parseError loc "Malformed entity string" where (first, rest) = break (== ' ') str -- - build cid header False lib = return $ - CImport cconv safety header lib (CFunction (StaticTarget cid)) - build cid header True lib = return $ - CImport cconv safety header lib (CLabel cid ) + build cid header False = return $ + CImport cconv safety header (CFunction (StaticTarget cid)) + build cid header True = return $ + CImport cconv safety header (CLabel cid ) -- -- Unravel a dotnet spec string. diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 52b1ec6..f51000d 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -108,7 +108,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do _ -> return () return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty))) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) = ASSERT( null arg_tys ) do { checkCg checkCOrAsm ; checkSafety safety @@ -116,7 +116,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _)) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well @@ -135,7 +135,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = _ -> addErrTc (illegalForeignTyErr empty sig_ty) return idecl -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrInterp checkCConv cconv -- 1.7.10.4