Commit c245355e authored by Simon Marlow's avatar Simon Marlow

Do not #include external header files when compiling via C

This has several advantages:

 - -fvia-C is consistent with -fasm with respect to FFI declarations:
   both bind to the ABI, not the API.

 - foreign calls can now be inlined freely across module boundaries, since
   a header file is not required when compiling the call.

 - bootstrapping via C will be more reliable, because this difference
   in behavour between the two backends has been removed.

There is one disadvantage:

 - we get no checking by the C compiler that the FFI declaration
   is correct.

So now, the c-includes field in a .cabal file is always ignored by
GHC, as are header files specified in an FFI declaration.  This was
previously the case only for -fasm compilations, now it is also the
case for -fvia-C too.
parent ab5c770b
......@@ -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?
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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 */
......@@ -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;
......
......@@ -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)
......
......@@ -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
......
......@@ -9,8 +9,6 @@
#ifndef GHC_RTS_TYPEABLE_H
#define GHC_RTS_TYPEABLE_H
#include "Stg.h"
void initTypeableStore(void);
void exitTypeableStore(void);
......
/* ----------------------------------------------------------------------------
*
* (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 */
/* ----------------------------------------------------------------------------
*
* (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)