diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/cmm/CLabel.hs | 26 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 4 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 54 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.lhs | 55 | ||||
| -rw-r--r-- | compiler/main/CodeOutput.lhs | 41 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 3 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 6 |
7 files changed, 79 insertions, 110 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 751575b0d1..a3c2634e35 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -105,6 +105,7 @@ module CLabel ( infoLblToEntryLbl, entryLblToInfoLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, + isMathFun, CLabelType(..), labelType, labelDynamic, pprCLabel @@ -462,7 +463,11 @@ needsCDecl ModuleRegdLabel = False needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False needsCDecl (RtsLabel _) = False -needsCDecl (ForeignLabel _ _ _) = False + -- RTS labels are declared in RTS header files. Otherwise we'd need + -- to give types for each label reference in the RTS .cmm files + -- somehow; when generating .cmm code we know the types of labels (info, + -- entry etc.) but for hand-written .cmm code we don't. +needsCDecl l@(ForeignLabel _ _ _) = not (isMathFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True @@ -478,6 +483,25 @@ maybeAsmTemp :: CLabel -> Maybe Unique maybeAsmTemp (AsmTempLabel uq) = Just uq maybeAsmTemp _ = Nothing +-- some labels have C prototypes in scope when compiling via C, because +-- they are builtin to the C compiler. For these labels we avoid +-- generating our own C prototypes. +isMathFun :: CLabel -> Bool +isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs + where + math_funs = [ + FSLIT("pow"), FSLIT("sin"), FSLIT("cos"), + FSLIT("tan"), FSLIT("sinh"), FSLIT("cosh"), + FSLIT("tanh"), FSLIT("asin"), FSLIT("acos"), + FSLIT("atan"), FSLIT("log"), FSLIT("exp"), + FSLIT("sqrt"), FSLIT("powf"), FSLIT("sinf"), + FSLIT("cosf"), FSLIT("tanf"), FSLIT("sinhf"), + FSLIT("coshf"), FSLIT("tanhf"), FSLIT("asinf"), + FSLIT("acosf"), FSLIT("atanf"), FSLIT("logf"), + FSLIT("expf"), FSLIT("sqrtf") + ] +isMathFun _ = False + -- ----------------------------------------------------------------------------- -- Is a CLabel visible outside this object file or not? diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 70cd7c4c5b..d387bf0465 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -200,7 +200,9 @@ static :: { ExtFCode [CmmStatic] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ - mkStaticClosure (mkRtsInfoLabelFS $3) + mkStaticClosure (mkForeignLabel $3 Nothing True) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. dontCareCCS (map getLit lits) [] [] [] } -- arrays of closures required for the CHARLIKE & INTLIKE arrays diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index ceadebe8e7..e46e0e7f89 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -201,25 +201,24 @@ pprStmt stmt = case stmt of rep = cmmExprRep src CmmCall (CmmCallee fn cconv) results args safety _ret -> - -- Controversial: leave this out for now. - -- pprUndef fn $$ - + maybe_proto $$ pprCall ppr_fn cconv results args safety where - ppr_fn = case fn of - CmmLit (CmmLabel lbl) -> pprCLabel lbl - _ -> parens (cCast (pprCFunType cconv results args) fn) - -- for a dynamic call, cast the expression to - -- a function of the right type (we hope). - - -- we #undef a function before calling it: the FFI is supposed to be - -- an interface specifically to C, not to C+CPP. For one thing, this - -- makes the via-C route more compatible with the NCG. If macros - -- are being used for optimisation, then inline functions are probably - -- better anyway. - pprUndef (CmmLit (CmmLabel lbl)) = - ptext SLIT("#undef") <+> pprCLabel lbl - pprUndef _ = empty + ppr_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) + + maybe_proto = + case fn of + CmmLit (CmmLabel lbl) | not (isMathFun lbl) -> + ptext SLIT(";EI_(") <+> pprCLabel lbl <> char ')' <> semi + -- we declare all called functions as data labels, + -- and then cast them to the right type when calling. + -- This is because the label might already have a + -- declaration as a data label in the same file, + -- e.g. Foreign.Marshal.Alloc declares 'free' as + -- both a data label and a function label. + _ -> + empty {- no proto -} + -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> pprCall ppr_fn CCallConv results args safety @@ -231,13 +230,11 @@ pprStmt stmt = case stmt of CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi CmmSwitch arg ids -> pprSwitch arg ids -pprCFunType :: CCallConv -> CmmFormals -> CmmActuals -> SDoc -pprCFunType cconv ress args - = hcat [ - res_type ress, - parens (text (ccallConvAttribute cconv) <> char '*'), - parens (commafy (map arg_type args)) - ] +pprCFunType :: SDoc -> CCallConv -> CmmFormals -> CmmActuals -> SDoc +pprCFunType ppr_fn cconv ress args + = res_type ress <+> + parens (text (ccallConvAttribute cconv) <> ppr_fn) <> + parens (commafy (map arg_type args)) where res_type [] = ptext SLIT("void") res_type [CmmHinted one hint] = machRepHintCType (localRegRep one) hint @@ -755,13 +752,12 @@ pprCall ppr_fn cconv results args _ <> pprUnHint hint (localRegRep one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" - pprArg (CmmHinted expr PtrHint) - = cCast (ptext SLIT("void *")) expr + pprArg (CmmHinted expr hint) + | hint `elem` [PtrHint,SignedHint] + = cCast (machRepHintCType (cmmExprRep expr) hint) expr -- see comment by machRepHintCType below - pprArg (CmmHinted expr SignedHint) - = cCast (machRepSignedCType (cmmExprRep expr)) expr pprArg (CmmHinted expr _other) - = pprExpr expr + = pprExpr expr pprUnHint PtrHint rep = parens (machRepCType rep) pprUnHint SignedHint rep = parens (machRepCType rep) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 9ad1d48791..1b269fab1f 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -76,27 +76,26 @@ dsForeigns [] dsForeigns fos = do fives <- mapM do_ldecl fos let - (hs, cs, hdrs, idss, bindss) = unzip5 fives + (hs, cs, idss, bindss) = unzip4 fives fe_ids = concat idss fe_init_code = map foreignExportInitialiser fe_ids -- return (ForeignStubs (vcat hs) - (vcat cs $$ vcat fe_init_code) - (nub (concat hdrs)), + (vcat cs $$ vcat fe_init_code), (concat bindss)) where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl) do_decl (ForeignImport id _ spec) = do traceIf (text "fi start" <+> ppr id) - (bs, h, c, mbhd) <- dsFImport (unLoc id) spec + (bs, h, c) <- dsFImport (unLoc id) spec traceIf (text "fi end" <+> ppr id) - return (h, c, maybeToList mbhd, [], bs) + return (h, c, [], bs) do_decl (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv))) = do (h, c, _, _) <- dsFExport id (idType id) ext_nm cconv False - return (h, c, [], [id], []) + return (h, c, [id], []) \end{code} @@ -127,51 +126,32 @@ because it exposes the boxing to the call site. \begin{code} dsFImport :: Id -> ForeignImport - -> DsM ([Binding], SDoc, SDoc, Maybe FastString) + -> DsM ([Binding], SDoc, SDoc) dsFImport id (CImport cconv safety header lib spec) = do - (ids, h, c) <- dsCImport id spec cconv safety no_hdrs - return (ids, h, c, if no_hdrs then Nothing else Just header) - where - no_hdrs = nullFS header + (ids, h, c) <- dsCImport id spec cconv safety + return (ids, h, c) -- FIXME: the `lib' field is needed for .NET ILX generation when invoking -- routines that are external to the .NET runtime, but GHC doesn't -- support such calls yet; if `nullFastString lib', the value was not given dsFImport id (DNImport spec) = do - (ids, h, c) <- dsFCall id (DNCall spec) True {- No headers -} - return (ids, h, c, Nothing) + (ids, h, c) <- dsFCall id (DNCall spec) + return (ids, h, c) dsCImport :: Id -> CImportSpec -> CCallConv -> Safety - -> Bool -- True <=> no headers in the f.i decl -> DsM ([Binding], SDoc, SDoc) -dsCImport id (CLabel cid) _ _ no_hdrs = do +dsCImport id (CLabel cid) _ _ = do (resTy, foRhs) <- resultWrapper (idType id) ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this let rhs = foRhs (mkLit (MachLabel cid Nothing)) in - return ([(setImpInline no_hdrs id, rhs)], empty, empty) -dsCImport id (CFunction target) cconv safety no_hdrs - = dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs -dsCImport id CWrapper cconv _ _ + return ([(id, rhs)], empty, empty) +dsCImport id (CFunction target) cconv safety + = dsFCall id (CCall (CCallSpec target cconv safety)) +dsCImport id CWrapper cconv _ = dsFExportDynamic id cconv - -setImpInline :: Bool -- True <=> No #include headers - -- in the foreign import declaration - -> Id -> Id --- If there is a #include header in the foreign import --- we make the worker non-inlinable, because we currently --- don't keep the #include stuff in the CCallId, and hence --- it won't be visible in the importing module, which can be --- fatal. --- (The #include stuff is just collected from the foreign import --- decls in a module.) --- If you want to do cross-module inlining of the c-calls themselves, --- put the #include stuff in the package spec, not the foreign --- import decl. -setImpInline True id = id -setImpInline False id = id `setInlinePragma` NeverActive \end{code} @@ -182,7 +162,7 @@ setImpInline False id = id `setInlinePragma` NeverActive %************************************************************************ \begin{code} -dsFCall fn_id fcall no_hdrs = do +dsFCall fn_id fcall = do let ty = idType fn_id (tvs, fun_ty) = tcSplitForAllTys ty @@ -229,8 +209,7 @@ dsFCall fn_id fcall no_hdrs = do worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = setImpInline no_hdrs $ -- See comments with setImpInline - mkSysLocal FSLIT("$wccall") work_uniq worker_ty + work_id = mkSysLocal FSLIT("$wccall") work_uniq worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index d6e130946c..fd67f2173a 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -24,7 +24,6 @@ import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages import Util -import FastString ( unpackFS ) import Cmm ( RawCmm ) import HscTypes import DynFlags @@ -32,7 +31,6 @@ import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Module -import List ( nub ) import Maybes ( firstJust ) import Distribution.Package ( showPackageId ) @@ -81,9 +79,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC ; case hscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; - HscC -> outputC dflags filenm this_mod location - flat_abstractC stubs_exist pkg_deps - foreign_stubs; + HscC -> outputC dflags filenm flat_abstractC pkg_deps; HscJava -> #ifdef JAVA outputJava dflags filenm mod_name tycons core_binds; @@ -108,15 +104,12 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action \begin{code} outputC :: DynFlags - -> FilePath -> Module -> ModLocation + -> FilePath -> [RawCmm] - -> (Bool, Bool) -> [PackageId] - -> ForeignStubs -> IO () -outputC dflags filenm mod location flat_absC - (stub_h_exists, _) packages foreign_stubs +outputC dflags filenm flat_absC packages = do -- figure out which header files to #include in the generated .hc file: -- @@ -124,38 +117,22 @@ outputC dflags filenm mod location flat_absC -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - pkg_configs <- getPreloadPackagesAnd dflags packages - let pkg_names = map (showPackageId.package) pkg_configs - - c_includes <- getPackageCIncludes pkg_configs - let cmdline_includes = cmdlineHcIncludes dflags -- -#include options - - ffi_decl_headers - = case foreign_stubs of - NoStubs -> [] - ForeignStubs _ _ fdhs -> map unpackFS (nub fdhs) - -- Remove duplicates, because distinct foreign import decls - -- may cite the same #include. Order doesn't matter. - - all_headers = c_includes - ++ reverse cmdline_includes - ++ ffi_decl_headers + let rts = getPackageDetails (pkgState dflags) rtsPackageId - let cc_injects = unlines (map mk_include all_headers) + let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = case h_file of '"':_{-"-} -> "#include "++h_file '<':_ -> "#include "++h_file _ -> "#include \""++h_file++"\"" + pkg_configs <- getPreloadPackagesAnd dflags packages + let pkg_names = map (showPackageId.package) pkg_configs + doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects - when stub_h_exists $ - hPutStrLn h ("#include \"" ++ inc_stub_h ++ "\"") writeCs dflags h flat_absC - where - (_, _, inc_stub_h) = mkStubPaths dflags (moduleName mod) location \end{code} @@ -226,7 +203,7 @@ outputForeignStubs dflags mod location stubs stub_h_exists <- doesFileExist stub_h return (stub_h_exists, stub_c_exists) - ForeignStubs h_code c_code _ -> do + ForeignStubs h_code c_code -> do let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index ec872626d0..ffb66eed59 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -629,9 +629,6 @@ data ForeignStubs = NoStubs -- "foreign exported" functions SDoc -- C stubs to use when calling -- "foreign exported" functions - [FastString] -- Headers that need to be included - -- into C code generated for this module - \end{code} \begin{code} diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 982085437c..a7c01aef6a 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -19,7 +19,6 @@ module Packages ( -- * Inspecting the set of packages in scope getPackageIncludePath, - getPackageCIncludes, getPackageLibraryPath, getPackageLinkOpts, getPackageExtraCcOpts, @@ -593,11 +592,6 @@ getPackageIncludePath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (nub (filter notNull (concatMap includeDirs ps))) - -- includes are in reverse dependency order (i.e. rts first) -getPackageCIncludes :: [PackageConfig] -> IO [String] -getPackageCIncludes pkg_configs = do - return (reverse (nub (filter notNull (concatMap includes pkg_configs)))) - getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String] getPackageLibraryPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs |