infoLblToEntryLbl, entryLblToInfoLbl,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
+ isMathFun,
CLabelType(..), labelType, labelDynamic,
pprCLabel
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
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?
| '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
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
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
<> 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)
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}
\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}
%************************************************************************
\begin{code}
-dsFCall fn_id fcall no_hdrs = do
+dsFCall fn_id fcall = do
let
ty = idType fn_id
(tvs, fun_ty) = tcSplitForAllTys ty
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
import CmmLint ( cmmLint )
import Packages
import Util
-import FastString ( unpackFS )
import Cmm ( RawCmm )
import HscTypes
import DynFlags
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
import Module
-import List ( nub )
import Maybes ( firstJust )
import Distribution.Package ( showPackageId )
; 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;
\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:
--
-- * -#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}
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
-- "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}
-- * Inspecting the set of packages in scope
getPackageIncludePath,
- getPackageCIncludes,
getPackageLibraryPath,
getPackageLinkOpts,
getPackageExtraCcOpts,
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
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 */
RtsAPI.h /* The top-level interface to the RTS (rts_evalIO(), etc.) */
HsFFI.h /* The external FFI api */
-
#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)
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:
// 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;
#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
/* 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)
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
#ifndef GHC_RTS_TYPEABLE_H\r
#define GHC_RTS_TYPEABLE_H\r
\r
-#include "Stg.h"\r
-\r
void initTypeableStore(void);\r
void exitTypeableStore(void);\r
\r
/* ----------------------------------------------------------------------------
*
- * (c) The GHC Team, 2005
+ * (c) The GHC Team, 2005-2008
*
- * Macros for THREADED_RTS support
+ * Macros for multi-CPU support
*
* -------------------------------------------------------------------------- */
#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 */
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 */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ *
+ * (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 */
--- /dev/null
+/* ----------------------------------------------------------------------------
+ *
+ * (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 */
+
#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
-------------------------------------------------------------------------- */
#include "StgDLL.h"
#include "MachRegs.h"
#include "Regs.h"
-#include "StgProf.h" /* ToDo: separate out RTS-only stuff from here */
#if IN_STG_CODE
/*
#include "StgMiscClosures.h"
#endif
-/* RTS external interface */
-#include "RtsExternal.h"
+#include "SMP.h" // write_barrier() inline is required
/* -----------------------------------------------------------------------------
Moving Floats and Doubles
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
-------------------------------------------------------------------------- */
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 */
#include "Cmm.h"
#include "RaiseAsync.h"
-#ifdef __PIC__
import ghczmprim_GHCziBool_True_closure;
-#endif
/* -----------------------------------------------------------------------------
Exception Primitives
+++ /dev/null
-/* 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"
#define RTS_SYMBOLS \
Maybe_Stable_Names \
- Sym(StgReturn) \
+ SymX(StgReturn) \
SymX(stg_enter_info) \
SymX(stg_gc_void_info) \
SymX(__stg_gc_enter_1) \
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
# 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"
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;
/* 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"
#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;
*
*/
#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
extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg);
-RTS_FUN(StgReturn);
-
#endif /* STGRUN_H */
*
* ---------------------------------------------------------------------------*/
-#include "RtsTypeable.h"
#include "Rts.h"
+#include "RtsTypeable.h"
static StgPtr typeableStore = 0;
#ifdef THREADED_RTS
projects / ghc-hetmet.git / commitdiff