diff options
| -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 | ||||
| -rw-r--r-- | includes/README | 13 | ||||
| -rw-r--r-- | includes/Regs.h | 23 | ||||
| -rw-r--r-- | includes/Rts.h | 6 | ||||
| -rw-r--r-- | includes/RtsExternal.h | 3 | ||||
| -rw-r--r-- | includes/RtsTypeable.h | 2 | ||||
| -rw-r--r-- | includes/SMP.h | 154 | ||||
| -rw-r--r-- | includes/SMPClosureOps.h | 71 | ||||
| -rw-r--r-- | includes/SpinLock.h | 110 | ||||
| -rw-r--r-- | includes/Stg.h | 9 | ||||
| -rw-r--r-- | includes/StgMiscClosures.h | 44 | ||||
| -rw-r--r-- | rts/Exception.cmm | 2 | ||||
| -rw-r--r-- | rts/HCIncludes.h | 24 | ||||
| -rw-r--r-- | rts/Linker.c | 2 | ||||
| -rw-r--r-- | rts/Makefile | 10 | ||||
| -rw-r--r-- | rts/PrimOps.cmm | 2 | ||||
| -rw-r--r-- | rts/StgCRun.c | 2 | ||||
| -rw-r--r-- | rts/StgMiscClosures.cmm | 10 | ||||
| -rw-r--r-- | rts/StgRun.h | 2 | ||||
| -rw-r--r-- | rts/Typeable.c | 2 |
26 files changed, 347 insertions, 333 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 diff --git a/includes/README b/includes/README index a63d02705f..fef91fe0fd 100644 --- a/includes/README +++ b/includes/README @@ -64,33 +64,35 @@ Rts.h StgDLL.h /* stuff related to Windows DLLs */ MachRegs.h /* global register assignments for this arch */ Regs.h /* "registers" in the virtual machine */ - StgProf.h /* profiling gubbins */ StgMiscClosures.h /* decls for closures & info tables in the RTS */ - RtsExternal.h /* decls for RTS things required by .hc code */ - (RtsAPI.h) - (HsFFI.h) + SMP.h /* basic primitives for synchronisation */ RtsTypes.h /* types used in the RTS */ Constants.h /* build-time constants */ StgLdvProf.h StgFun.h + StgProf.h /* profiling gubbins */ Closures.h Liveness.h /* macros for constructing RET_DYN liveness masks */ ClosureMacros.h ClosureTypes.h InfoTables.h + SMPClosureOps.h /* lockClosure/unlockClosure etc. */ + SpinLock.h TSO.h Updates.h /* macros for performing updates */ GranSim.h Parallel.h - SMP.h Block.h Stable.h Hooks.h Signals.h DNInvoke.h Dotnet.h + RtsExternal.h /* decls for RTS things required by .hc code */ + (RtsAPI.h) + (HsFFI.h) Cmm.h /* included into .cmm source only */ DerivedConstants.h /* generated by mkDerivedConstants.c from other */ @@ -110,4 +112,3 @@ ieee-flpt.h /* ToDo: needed? */ RtsAPI.h /* The top-level interface to the RTS (rts_evalIO(), etc.) */ HsFFI.h /* The external FFI api */ - diff --git a/includes/Regs.h b/includes/Regs.h index 6524c8f669..0f974ec4ad 100644 --- a/includes/Regs.h +++ b/includes/Regs.h @@ -22,14 +22,6 @@ #ifndef REGS_H #define REGS_H -#if defined(HAVE_FRAMEWORK_GMP) -#include <GMP/gmp.h> -#elif defined(HAVE_LIB_GMP) -#include <gmp.h> -#else -#include "gmp.h" // Needs MP_INT definition -#endif - /* * Spark pools: used to store pending sparks * (THREADED_RTS & PARALLEL_HASKELL only) @@ -79,6 +71,11 @@ typedef union { StgTSOPtr t; } StgUnion; +// Urgh.. we don't know the size of an MP_INT here because we haven't +// #included gmp.h. We should really autoconf this, but GMP may not +// be available at ./configure time if we're building it (GMP) locally. +#define MP_INT_WORDS 3 + /* * This is the table that holds shadow-locations for all the STG * registers. The shadow locations are used when: @@ -117,11 +114,11 @@ typedef struct StgRegTable_ { // rmp_tmp1..rmp_result2 are only used in THREADED_RTS builds to // avoid per-thread temps in bss, but currently always incldue here // so we just run mkDerivedConstants once - StgWord rmp_tmp_w; - MP_INT rmp_tmp1; - MP_INT rmp_tmp2; - MP_INT rmp_result1; - MP_INT rmp_result2; + StgWord rmp_tmp_w[MP_INT_WORDS]; + StgWord rmp_tmp1[MP_INT_WORDS]; + StgWord rmp_tmp2[MP_INT_WORDS]; + StgWord rmp_result1[MP_INT_WORDS]; + StgWord rmp_result2[MP_INT_WORDS]; StgWord rRet; // holds the return code of the thread StgSparkPool rSparks; /* per-task spark pool */ } StgRegTable; diff --git a/includes/Rts.h b/includes/Rts.h index df8cb46900..cec93e68b0 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -18,6 +18,9 @@ extern "C" { #endif #include "Stg.h" +// ToDo: move RtsExternal stuff elsewhere +#include "RtsExternal.h" + // Turn off inlining when debugging - it obfuscates things #ifdef DEBUG # undef STATIC_INLINE @@ -165,7 +168,8 @@ TAG_CLOSURE(StgWord tag,StgClosure * p) /* Parallel information */ #include "Parallel.h" #include "OSThreads.h" -#include "SMP.h" +#include "SMPClosureOps.h" +#include "SpinLock.h" /* GNU mp library */ #if defined(HAVE_FRAMEWORK_GMP) diff --git a/includes/RtsExternal.h b/includes/RtsExternal.h index b95da387bd..24dace2b14 100644 --- a/includes/RtsExternal.h +++ b/includes/RtsExternal.h @@ -111,9 +111,6 @@ extern void setIOManagerPipe (int fd); extern void* allocateExec(unsigned int len); // Breakpoint stuff -extern int rts_stop_next_breakpoint; -extern int rts_stop_on_exception; -extern HsStablePtr rts_breakpoint_io_action; /* ----------------------------------------------------------------------------- Storage manager stuff exported diff --git a/includes/RtsTypeable.h b/includes/RtsTypeable.h index 28b59cdc13..343c514ace 100644 --- a/includes/RtsTypeable.h +++ b/includes/RtsTypeable.h @@ -9,8 +9,6 @@ #ifndef GHC_RTS_TYPEABLE_H
#define GHC_RTS_TYPEABLE_H
-#include "Stg.h"
-
void initTypeableStore(void);
void exitTypeableStore(void);
diff --git a/includes/SMP.h b/includes/SMP.h index a91e5d5619..0e6322d40b 100644 --- a/includes/SMP.h +++ b/includes/SMP.h @@ -1,8 +1,8 @@ /* ---------------------------------------------------------------------------- * - * (c) The GHC Team, 2005 + * (c) The GHC Team, 2005-2008 * - * Macros for THREADED_RTS support + * Macros for multi-CPU support * * -------------------------------------------------------------------------- */ @@ -175,132 +175,6 @@ write_barrier(void) { #endif } -/* ----------------------------------------------------------------------------- - * Locking/unlocking closures - * - * This is used primarily in the implementation of MVars. - * -------------------------------------------------------------------------- */ - -#define SPIN_COUNT 4000 - -#ifdef KEEP_LOCKCLOSURE -// We want a callable copy of lockClosure() so that we can refer to it -// from .cmm files compiled using the native codegen. -extern StgInfoTable *lockClosure(StgClosure *p); -INLINE_ME -#else -INLINE_HEADER -#endif -StgInfoTable * -lockClosure(StgClosure *p) -{ - StgWord info; - do { - nat i = 0; - do { - info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); - if (info != (W_)&stg_WHITEHOLE_info) return (StgInfoTable *)info; - } while (++i < SPIN_COUNT); - yieldThread(); - } while (1); -} - -INLINE_HEADER void -unlockClosure(StgClosure *p, const StgInfoTable *info) -{ - // This is a strictly ordered write, so we need a write_barrier(): - write_barrier(); - p->header.info = info; -} - -/* ----------------------------------------------------------------------------- - * Spin locks - * - * These are simple spin-only locks as opposed to Mutexes which - * probably spin for a while before blocking in the kernel. We use - * these when we are sure that all our threads are actively running on - * a CPU, eg. in the GC. - * - * TODO: measure whether we really need these, or whether Mutexes - * would do (and be a bit safer if a CPU becomes loaded). - * -------------------------------------------------------------------------- */ - -#if defined(DEBUG) -typedef struct StgSync_ -{ - StgWord32 lock; - StgWord64 spin; // DEBUG version counts how much it spins -} StgSync; -#else -typedef StgWord StgSync; -#endif - -typedef lnat StgSyncCount; - - -#if defined(DEBUG) - -// Debug versions of spin locks maintain a spin count - -// How to use: -// To use the debug veriosn of the spin locks, a debug version of the program -// can be run under a deugger with a break point on stat_exit. At exit time -// of the program one can examine the state the spin count counts of various -// spin locks to check for contention. - -// acquire spin lock -INLINE_HEADER void ACQUIRE_SPIN_LOCK(StgSync * p) -{ - StgWord32 r = 0; - do { - p->spin++; - r = cas((StgVolatilePtr)&(p->lock), 1, 0); - } while(r == 0); - p->spin--; -} - -// release spin lock -INLINE_HEADER void RELEASE_SPIN_LOCK(StgSync * p) -{ - write_barrier(); - p->lock = 1; -} - -// initialise spin lock -INLINE_HEADER void initSpinLock(StgSync * p) -{ - write_barrier(); - p->lock = 1; - p->spin = 0; -} - -#else - -// acquire spin lock -INLINE_HEADER void ACQUIRE_SPIN_LOCK(StgSync * p) -{ - StgWord32 r = 0; - do { - r = cas((StgVolatilePtr)p, 1, 0); - } while(r == 0); -} - -// release spin lock -INLINE_HEADER void RELEASE_SPIN_LOCK(StgSync * p) -{ - write_barrier(); - (*p) = 1; -} - -// init spin lock -INLINE_HEADER void initSpinLock(StgSync * p) -{ - write_barrier(); - (*p) = 1; -} - -#endif /* DEBUG */ - /* ---------------------------------------------------------------------- */ #else /* !THREADED_RTS */ @@ -314,30 +188,8 @@ xchg(StgPtr p, StgWord w) return old; } -INLINE_HEADER StgInfoTable * -lockClosure(StgClosure *p) -{ return (StgInfoTable *)p->header.info; } - -INLINE_HEADER void -unlockClosure(StgClosure *p STG_UNUSED, const StgInfoTable *info STG_UNUSED) -{ /* nothing */ } - -// Using macros here means we don't have to ensure the argument is in scope -#define ACQUIRE_SPIN_LOCK(p) /* nothing */ -#define RELEASE_SPIN_LOCK(p) /* nothing */ - -INLINE_HEADER void initSpinLock(void * p STG_UNUSED) -{ /* nothing */ } - #endif /* !THREADED_RTS */ -// Handy specialised versions of lockClosure()/unlockClosure() -INLINE_HEADER void lockTSO(StgTSO *tso) -{ lockClosure((StgClosure *)tso); } - -INLINE_HEADER void unlockTSO(StgTSO *tso) -{ unlockClosure((StgClosure*)tso, (const StgInfoTable *)&stg_TSO_info); } +#endif /* CMINUSMINUS */ #endif /* SMP_H */ - -#endif /* CMINUSMINUS */ diff --git a/includes/SMPClosureOps.h b/includes/SMPClosureOps.h new file mode 100644 index 0000000000..fe78168011 --- /dev/null +++ b/includes/SMPClosureOps.h @@ -0,0 +1,71 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2005 + * + * Macros for THREADED_RTS support + * + * -------------------------------------------------------------------------- */ + +#ifndef SMPCLOSUREOPS_H +#define SMPCLOSUREOPS_H + +#if defined(THREADED_RTS) + +/* ----------------------------------------------------------------------------- + * Locking/unlocking closures + * + * This is used primarily in the implementation of MVars. + * -------------------------------------------------------------------------- */ + +#define SPIN_COUNT 4000 + +#ifdef KEEP_LOCKCLOSURE +// We want a callable copy of lockClosure() so that we can refer to it +// from .cmm files compiled using the native codegen. +extern StgInfoTable *lockClosure(StgClosure *p); +INLINE_ME +#else +INLINE_HEADER +#endif +StgInfoTable * +lockClosure(StgClosure *p) +{ + StgWord info; + do { + nat i = 0; + do { + info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); + if (info != (W_)&stg_WHITEHOLE_info) return (StgInfoTable *)info; + } while (++i < SPIN_COUNT); + yieldThread(); + } while (1); +} + +INLINE_HEADER void +unlockClosure(StgClosure *p, const StgInfoTable *info) +{ + // This is a strictly ordered write, so we need a write_barrier(): + write_barrier(); + p->header.info = info; +} + +#else /* !THREADED_RTS */ + +INLINE_HEADER StgInfoTable * +lockClosure(StgClosure *p) +{ return (StgInfoTable *)p->header.info; } + +INLINE_HEADER void +unlockClosure(StgClosure *p STG_UNUSED, const StgInfoTable *info STG_UNUSED) +{ /* nothing */ } + +#endif /* THREADED_RTS */ + +// Handy specialised versions of lockClosure()/unlockClosure() +INLINE_HEADER void lockTSO(StgTSO *tso) +{ lockClosure((StgClosure *)tso); } + +INLINE_HEADER void unlockTSO(StgTSO *tso) +{ unlockClosure((StgClosure*)tso, (const StgInfoTable *)&stg_TSO_info); } + +#endif /* SMPCLOSUREOPS_H */ diff --git a/includes/SpinLock.h b/includes/SpinLock.h new file mode 100644 index 0000000000..de08ca1aa5 --- /dev/null +++ b/includes/SpinLock.h @@ -0,0 +1,110 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2006-2008 + * + * Spin locks + * + * These are simple spin-only locks as opposed to Mutexes which + * probably spin for a while before blocking in the kernel. We use + * these when we are sure that all our threads are actively running on + * a CPU, eg. in the GC. + * + * TODO: measure whether we really need these, or whether Mutexes + * would do (and be a bit safer if a CPU becomes loaded). + * + * -------------------------------------------------------------------------- */ + +#ifndef SPINLOCK_H +#define SPINLOCK_H + +#if defined(THREADED_RTS) + +#if defined(DEBUG) +typedef struct StgSync_ +{ + StgWord32 lock; + StgWord64 spin; // DEBUG version counts how much it spins +} StgSync; +#else +typedef StgWord StgSync; +#endif + +typedef lnat StgSyncCount; + + +#if defined(DEBUG) + +// Debug versions of spin locks maintain a spin count + +// How to use: +// To use the debug veriosn of the spin locks, a debug version of the program +// can be run under a deugger with a break point on stat_exit. At exit time +// of the program one can examine the state the spin count counts of various +// spin locks to check for contention. + +// acquire spin lock +INLINE_HEADER void ACQUIRE_SPIN_LOCK(StgSync * p) +{ + StgWord32 r = 0; + do { + p->spin++; + r = cas((StgVolatilePtr)&(p->lock), 1, 0); + } while(r == 0); + p->spin--; +} + +// release spin lock +INLINE_HEADER void RELEASE_SPIN_LOCK(StgSync * p) +{ + write_barrier(); + p->lock = 1; +} + +// initialise spin lock +INLINE_HEADER void initSpinLock(StgSync * p) +{ + write_barrier(); + p->lock = 1; + p->spin = 0; +} + +#else + +// acquire spin lock +INLINE_HEADER void ACQUIRE_SPIN_LOCK(StgSync * p) +{ + StgWord32 r = 0; + do { + r = cas((StgVolatilePtr)p, 1, 0); + } while(r == 0); +} + +// release spin lock +INLINE_HEADER void RELEASE_SPIN_LOCK(StgSync * p) +{ + write_barrier(); + (*p) = 1; +} + +// init spin lock +INLINE_HEADER void initSpinLock(StgSync * p) +{ + write_barrier(); + (*p) = 1; +} + +#endif /* DEBUG */ + +#else /* !THREADED_RTS */ + +// Using macros here means we don't have to ensure the argument is in scope +#define ACQUIRE_SPIN_LOCK(p) /* nothing */ +#define RELEASE_SPIN_LOCK(p) /* nothing */ + +INLINE_HEADER void initSpinLock(void * p STG_UNUSED) +{ /* nothing */ } + +#endif /* THREADED_RTS */ + +#endif /* SPINLOCK_H */ + diff --git a/includes/Stg.h b/includes/Stg.h index 1facd5f405..6ddf17a0a0 100644 --- a/includes/Stg.h +++ b/includes/Stg.h @@ -41,6 +41,11 @@ #include "ghcconfig.h" #include "RtsConfig.h" +/* The code generator calls the math functions directly in .hc code. + NB. after configuration stuff above, because this sets #defines + that depend on config info, such as __USE_FILE_OFFSET64 */ +#include <math.h> + /* ----------------------------------------------------------------------------- Useful definitions -------------------------------------------------------------------------- */ @@ -148,7 +153,6 @@ typedef StgWord StgWordArray[]; #include "StgDLL.h" #include "MachRegs.h" #include "Regs.h" -#include "StgProf.h" /* ToDo: separate out RTS-only stuff from here */ #if IN_STG_CODE /* @@ -158,8 +162,7 @@ typedef StgWord StgWordArray[]; #include "StgMiscClosures.h" #endif -/* RTS external interface */ -#include "RtsExternal.h" +#include "SMP.h" // write_barrier() inline is required /* ----------------------------------------------------------------------------- Moving Floats and Doubles diff --git a/includes/StgMiscClosures.h b/includes/StgMiscClosures.h index a99ff72a22..c82ec05bd4 100644 --- a/includes/StgMiscClosures.h +++ b/includes/StgMiscClosures.h @@ -493,6 +493,12 @@ RTS_FUN(stg_threadFinished); RTS_FUN(stg_init_finish); RTS_FUN(stg_init); +RTS_FUN(StgReturn); + +extern int rts_stop_next_breakpoint; +extern int rts_stop_on_exception; +extern void *rts_breakpoint_io_action; + /* ----------------------------------------------------------------------------- PrimOps -------------------------------------------------------------------------- */ @@ -598,4 +604,42 @@ RTS_FUN(getApStackValzh_fast); RTS_FUN(noDuplicatezh_fast); +/* Other misc stuff */ + +#if IN_STG_CODE && !IN_STGCRUN + +// Schedule.c +extern int RTS_VAR(context_switch); +extern StgWord RTS_VAR(blocked_queue_hd), RTS_VAR(blocked_queue_tl); +extern StgWord RTS_VAR(sleeping_queue); +extern StgWord RTS_VAR(blackhole_queue); +extern StgWord RTS_VAR(sched_mutex); + +// Apply.cmm +// canned bitmap for each arg type +extern StgWord stg_arg_bitmaps[]; + +// Storage.c +extern unsigned int RTS_VAR(alloc_blocks); +extern unsigned int RTS_VAR(alloc_blocks_lim); +extern StgWord RTS_VAR(weak_ptr_list); +extern StgWord RTS_VAR(atomic_modify_mutvar_mutex); + +// RtsFlags +extern StgWord RTS_VAR(RtsFlags); // bogus type + +// Stable.c +extern StgWord RTS_VAR(stable_ptr_table); + +// Profiling.c +extern unsigned int RTS_VAR(era); +extern StgWord RTS_VAR(CCCS); /* current CCS */ +extern unsigned int RTS_VAR(entering_PAP); +extern StgWord RTS_VAR(CC_LIST); /* registered CC list */ +extern StgWord RTS_VAR(CCS_LIST); /* registered CCS list */ +extern unsigned int RTS_VAR(CC_ID); /* global ids */ +extern unsigned int RTS_VAR(CCS_ID); + +#endif + #endif /* STGMISCCLOSURES_H */ diff --git a/rts/Exception.cmm b/rts/Exception.cmm index c2f0dde675..daa8e4fd7f 100644 --- a/rts/Exception.cmm +++ b/rts/Exception.cmm @@ -13,9 +13,7 @@ #include "Cmm.h" #include "RaiseAsync.h" -#ifdef __PIC__ import ghczmprim_GHCziBool_True_closure; -#endif /* ----------------------------------------------------------------------------- Exception Primitives diff --git a/rts/HCIncludes.h b/rts/HCIncludes.h deleted file mode 100644 index 38ca34aac7..0000000000 --- a/rts/HCIncludes.h +++ /dev/null @@ -1,24 +0,0 @@ -/* includes for compiling .cmm files via-C */ -#include "Stg.h" -#include "Rts.h" -#include "RtsFlags.h" -#include "RtsUtils.h" -#include "StgRun.h" -#include "Storage.h" -#include "Schedule.h" -#include "Printer.h" -#include "Sanity.h" -#include "STM.h" -#include "SchedAPI.h" -#include "Timer.h" -#include "ProfHeap.h" -#include "LdvProfile.h" -#include "Profiling.h" -#include "OSThreads.h" -#include "Apply.h" -#include "SMP.h" -#include "RaiseAsync.h" -#include "ThreadLabels.h" -#include "Threads.h" -#include "Prelude.h" -#include "Stable.h" diff --git a/rts/Linker.c b/rts/Linker.c index e2391842a2..59143b9b0e 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -482,7 +482,7 @@ typedef struct _RtsSymbolVal { #define RTS_SYMBOLS \ Maybe_Stable_Names \ - Sym(StgReturn) \ + SymX(StgReturn) \ SymX(stg_enter_info) \ SymX(stg_gc_void_info) \ SymX(__stg_gc_enter_1) \ diff --git a/rts/Makefile b/rts/Makefile index 2a20279382..6fb168824a 100644 --- a/rts/Makefile +++ b/rts/Makefile @@ -152,6 +152,8 @@ SRC_CC_OPTS += $(STANDARD_OPTS) SRC_CC_OPTS += $(GhcRtsCcOpts) SRC_HC_OPTS += $(GhcRtsHcOpts) $(STANDARD_OPTS) -package-name rts +SRC_HC_OPTS += -fvia-C + ifneq "$(GhcWithSMP)" "YES" SRC_CC_OPTS += -DNOSMP SRC_HC_OPTS += -optc-DNOSMP @@ -366,13 +368,7 @@ endif # Compiling the cmm files # ToDo: should we really include Rts.h here? Required for GNU_ATTRIBUTE(). -SRC_HC_OPTS += -I. -\#include HCIncludes.h - -ifeq "$(Windows)" "YES" -PrimOps_HC_OPTS += -\#include '<windows.h>' -\#include win32/AsyncIO.h -else -PrimOps_HC_OPTS += -\#include posix/Itimer.h -endif +SRC_HC_OPTS += -I. # Otherwise the stack-smash handler gets triggered. ifeq "$(TargetOS_CPP)" "openbsd" diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 06628b96f8..99d6475455 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -46,10 +46,10 @@ import __gmpz_xor; import __gmpz_ior; import __gmpz_com; #endif -import base_GHCziIOBase_NestedAtomically_closure; import pthread_mutex_lock; import pthread_mutex_unlock; #endif +import base_GHCziIOBase_NestedAtomically_closure; import EnterCriticalSection; import LeaveCriticalSection; diff --git a/rts/StgCRun.c b/rts/StgCRun.c index 376e824055..a211da3577 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -66,6 +66,8 @@ register double fake_f9 __asm__("$f9"); /* include Stg.h first because we want real machine regs in here: we * have to get the value of R1 back from Stg land to C land intact. */ +// yeuch +#define IN_STGCRUN 1 #include "Stg.h" #include "Rts.h" #include "StgRun.h" diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 0a4dbdc561..270c600f7c 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -12,11 +12,9 @@ #include "Cmm.h" -#ifdef __PIC__ import pthread_mutex_lock; import base_GHCziBase_Czh_static_info; import base_GHCziBase_Izh_static_info; -#endif import EnterCriticalSection; import LeaveCriticalSection; @@ -608,11 +606,11 @@ CLOSURE(stg_dummy_ret_closure,stg_dummy_ret); * */ #warning Is this correct? _imp is a pointer! -#define Char_hash_static_info _imp__base_GHCziBase_Czh_static -#define Int_hash_static_info _imp__base_GHCziBase_Izh_static +#define Char_hash_static_info _imp__base_GHCziBase_Czh_static_info +#define Int_hash_static_info _imp__base_GHCziBase_Izh_static_info #else -#define Char_hash_static_info base_GHCziBase_Czh_static -#define Int_hash_static_info base_GHCziBase_Izh_static +#define Char_hash_static_info base_GHCziBase_Czh_static_info +#define Int_hash_static_info base_GHCziBase_Izh_static_info #endif diff --git a/rts/StgRun.h b/rts/StgRun.h index da376b4971..12d1475d13 100644 --- a/rts/StgRun.h +++ b/rts/StgRun.h @@ -11,6 +11,4 @@ extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); -RTS_FUN(StgReturn); - #endif /* STGRUN_H */ diff --git a/rts/Typeable.c b/rts/Typeable.c index 66e135ca1f..88151b7d47 100644 --- a/rts/Typeable.c +++ b/rts/Typeable.c @@ -6,8 +6,8 @@ * * ---------------------------------------------------------------------------*/ -#include "RtsTypeable.h" #include "Rts.h" +#include "RtsTypeable.h" static StgPtr typeableStore = 0; #ifdef THREADED_RTS |