Do not #include external header files when compiling via C
authorSimon Marlow <simonmar@microsoft.com>
Wed, 2 Apr 2008 05:14:12 +0000 (05:14 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Wed, 2 Apr 2008 05:14:12 +0000 (05:14 +0000)
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.

26 files changed:
compiler/cmm/CLabel.hs
compiler/cmm/CmmParse.y
compiler/cmm/PprC.hs
compiler/deSugar/DsForeign.lhs
compiler/main/CodeOutput.lhs
compiler/main/HscTypes.lhs
compiler/main/Packages.lhs
includes/README
includes/Regs.h
includes/Rts.h
includes/RtsExternal.h
includes/RtsTypeable.h
includes/SMP.h
includes/SMPClosureOps.h [new file with mode: 0644]
includes/SpinLock.h [new file with mode: 0644]
includes/Stg.h
includes/StgMiscClosures.h
rts/Exception.cmm
rts/HCIncludes.h [deleted file]
rts/Linker.c
rts/Makefile
rts/PrimOps.cmm
rts/StgCRun.c
rts/StgMiscClosures.cmm
rts/StgRun.h
rts/Typeable.c

index 751575b..a3c2634 100644 (file)
@@ -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?
 
index 70cd7c4..d387bf0 100644 (file)
@@ -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
 
index ceadebe..e46e0e7 100644 (file)
@@ -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)
index 9ad1d48..1b269fa 100644 (file)
@@ -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
index d6e1309..fd67f21 100644 (file)
@@ -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
index ec87262..ffb66ee 100644 (file)
@@ -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}
index 9820854..a7c01ae 100644 (file)
@@ -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
index a63d027..fef91fe 100644 (file)
@@ -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 */
-  
index 6524c8f..0f974ec 100644 (file)
 #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;
index df8cb46..cec93e6 100644 (file)
@@ -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)
index b95da38..24dace2 100644 (file)
@@ -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
index 28b59cd..343c514 100644 (file)
@@ -9,8 +9,6 @@
 #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
index a91e5d5..0e6322d 100644 (file)
@@ -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 (file)
index 0000000..fe78168
--- /dev/null
@@ -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 (file)
index 0000000..de08ca1
--- /dev/null
@@ -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 */
+
index 1facd5f..6ddf17a 100644 (file)
 #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
index a99ff72..c82ec05 100644 (file)
@@ -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 */
index c2f0dde..daa8e4f 100644 (file)
@@ -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 (file)
index 38ca34a..0000000
+++ /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"
index e239184..59143b9 100644 (file)
@@ -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)                   \
index 2a20279..6fb1688 100644 (file)
@@ -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"
index 06628b9..99d6475 100644 (file)
@@ -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;
 
index 376e824..a211da3 100644 (file)
@@ -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"
index 0a4dbdc..270c600 100644 (file)
 
 #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
 
 
index da376b4..12d1475 100644 (file)
@@ -11,6 +11,4 @@
 
 extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg);
 
-RTS_FUN(StgReturn);
-
 #endif /* STGRUN_H */
index 66e135c..88151b7 100644 (file)
@@ -6,8 +6,8 @@
  *
  * ---------------------------------------------------------------------------*/
 
-#include "RtsTypeable.h"
 #include "Rts.h"
+#include "RtsTypeable.h"
 
 static StgPtr typeableStore = 0;
 #ifdef THREADED_RTS