Make GHCi & TH work when the compiler is built with -prof
authorSimon Marlow <marlowsd@gmail.com>
Sat, 7 Nov 2015 09:39:05 +0000 (09:39 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Sat, 7 Nov 2015 09:39:05 +0000 (09:39 +0000)
Summary:
Amazingly, there were zero changes to the byte code generator and very
few changes to the interpreter - mainly because we've used good
abstractions that hide the differences between profiling and
non-profiling.  So that bit was pleasantly straightforward, but there
were a pile of other wibbles to get the whole test suite through.

Note that a compiler built with -prof is now like one built with
-dynamic, in that to use TH you have to build the code the same way.
For dynamic, we automatically enable -dynamic-too when TH is required,
but we don't have anything equivalent for profiling, so you have to
explicitly use -prof when building code that uses TH with a profiled
compiler.  For this reason Cabal won't work with TH.  We don't expect
to ship a profiled compiler, so I think that's OK.

Test Plan: validate with GhcProfiled=YES in validate.mk

Reviewers: goldfire, bgamari, rwbarton, austin, hvr, erikd, ezyang

Reviewed By: ezyang

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1407

GHC Trac Issues: #4837, #545

58 files changed:
compiler/cmm/CmmInfo.hs
compiler/codeGen/StgCmmProf.hs
compiler/ghci/ByteCodeItbls.hs
compiler/ghci/Linker.hs
compiler/ghci/RtClosureInspect.hs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
ghc/InteractiveUI.hs
includes/rts/prof/CCS.h
includes/rts/storage/InfoTables.h
rts/Interpreter.c
rts/Linker.c
rts/PrimOps.cmm
rts/ProfHeap.c
rts/Profiling.c
rts/Profiling.h
rts/RtsStartup.c
rts/RtsSymbols.c
testsuite/config/ghc
testsuite/mk/boilerplate.mk
testsuite/mk/ghc-config.hs
testsuite/tests/annotations/should_compile/all.T
testsuite/tests/annotations/should_compile/th/Makefile
testsuite/tests/annotations/should_compile/th/all.T
testsuite/tests/annotations/should_compile/th/annth.hs
testsuite/tests/annotations/should_run/all.T
testsuite/tests/cabal/cabal04/Makefile
testsuite/tests/cabal/cabal04/all.T
testsuite/tests/ghc-e/should_fail/all.T
testsuite/tests/ghc-e/should_run/all.T
testsuite/tests/ghci.debugger/scripts/all.T
testsuite/tests/ghci.debugger/scripts/break022/all.T
testsuite/tests/ghci.debugger/scripts/break023/all.T
testsuite/tests/ghci/scripts/all.T
testsuite/tests/ghci/should_fail/all.T
testsuite/tests/ghci/should_run/all.T
testsuite/tests/layout/all.T
testsuite/tests/overloadedrecflds/ghci/all.T
testsuite/tests/partial-sigs/should_compile/all.T
testsuite/tests/partial-sigs/should_fail/all.T
testsuite/tests/plugins/annotation-plugin/Makefile
testsuite/tests/plugins/rule-defining-plugin/Makefile
testsuite/tests/plugins/simple-plugin/Makefile
testsuite/tests/profiling/should_run/ioprof.prof.sample
testsuite/tests/profiling/should_run/ioprof.stderr
testsuite/tests/quasiquotation/qq007/Makefile
testsuite/tests/quasiquotation/qq007/test.T
testsuite/tests/quasiquotation/qq008/Makefile
testsuite/tests/quasiquotation/qq008/test.T
testsuite/tests/quasiquotation/qq009/Makefile
testsuite/tests/quasiquotation/qq009/test.T
testsuite/tests/runghc/all.T
testsuite/tests/th/Makefile
testsuite/tests/th/T2014/all.T
testsuite/tests/th/T4255.hs [deleted file]
testsuite/tests/th/T4255.stderr [deleted file]
testsuite/tests/th/TH_import_loop/TH_import_loop.T
testsuite/tests/th/all.T

index ce8b9f8..723f7fc 100644 (file)
@@ -26,6 +26,7 @@ module CmmInfo (
   maxStdInfoTableSizeW,
   maxRetInfoTableSizeW,
   stdInfoTableSizeB,
+  conInfoTableSizeB,
   stdSrtBitmapOffset,
   stdClosureTypeOffset,
   stdPtrsOffset, stdNonPtrsOffset,
@@ -551,3 +552,6 @@ stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
 stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
 stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
 stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+
+conInfoTableSizeB :: DynFlags -> Int
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
index a7384c7..efad805 100644 (file)
@@ -321,14 +321,15 @@ dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
 -- Initialise the LDV word of a new closure
 --
 ldvRecordCreate :: CmmExpr -> FCode ()
-ldvRecordCreate closure = do dflags <- getDynFlags
-                             emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
+ldvRecordCreate closure = do
+  dflags <- getDynFlags
+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
 
 --
--- Called when a closure is entered, marks the closure as having been "used".
--- The closure is not an 'inherently used' one.
--- The closure is not IND or IND_OLDGEN because neither is considered for LDV
--- profiling.
+-- | Called when a closure is entered, marks the closure as having
+-- been "used".  The closure is not an "inherently used" one.  The
+-- closure is not @IND@ or @IND_OLDGEN@ because neither is considered
+-- for LDV profiling.
 --
 ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
 ldvEnterClosure closure_info node_reg = do
index a01fcd8..01420f5 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -20,6 +20,7 @@ import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
 import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
 import Type             ( flattenRepType, repType, typePrimRep )
 import StgCmmLayout     ( mkVirtHeapOffsets )
+import CmmInfo          ( conInfoTableSizeB, profInfoTableSizeW )
 import Util
 
 import Control.Monad
@@ -43,10 +44,6 @@ itblCode dflags (ItblPtr ptr)
  | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags
  | otherwise            = castPtr ptr
 
--- XXX bogus
-conInfoTableSizeB :: DynFlags -> Int
-conInfoTableSizeB dflags = 3 * wORD_SIZE dflags
-
 type ItblEnv = NameEnv (Name, ItblPtr)
         -- We need the Name in the range so we know which
         -- elements to filter out when unloading a module
@@ -258,8 +255,10 @@ foreign import ccall "&stg_interp_constr_entry"
 -- Ultra-minimalist version specially for constructors
 #if SIZEOF_VOID_P == 8
 type HalfWord = Word32
+type FullWord = Word64
 #else
 type HalfWord = Word16
+type FullWord = Word32
 #endif
 
 data StgConInfoTable = StgConInfoTable {
@@ -311,6 +310,8 @@ sizeOfItbl dflags itbl
                                       Right xs -> sizeOf (head xs) * length xs
                                  else 0
         ]
+        + if rtsIsProfiled then profInfoTableSizeW * wORD_SIZE dflags
+                           else 0
 
 pokeItbl :: DynFlags -> Ptr StgInfoTable -> StgInfoTable -> IO ()
 pokeItbl _ a0 itbl
@@ -319,6 +320,9 @@ pokeItbl _ a0 itbl
            case entry itbl of
                Nothing -> return ()
                Just e  -> store e
+           when rtsIsProfiled $ do
+              store (0 :: FullWord)
+              store (0 :: FullWord)
            store (ptrs   itbl)
            store (nptrs  itbl)
            store (tipe   itbl)
@@ -335,6 +339,10 @@ peekItbl dflags a0
            entry'  <- if ghciTablesNextToCode
                       then return Nothing
                       else liftM Just load
+           when rtsIsProfiled $ do
+              (_ :: Ptr FullWord) <- advance
+              (_ :: Ptr FullWord) <- advance
+              return ()
            ptrs'   <- load
            nptrs'  <- load
            tipe'   <- load
index f62998c..9fa89fe 100644 (file)
@@ -504,24 +504,20 @@ dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mk
 
 
 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
-checkNonStdWay dflags srcspan =
-  if interpWays == haskellWays
-      then return Nothing
-    -- see #3604: object files compiled for way "dyn" need to link to the
-    -- dynamic packages, so we can't load them into a statically-linked GHCi.
-    -- we have to treat "dyn" in the same way as "prof".
-    --
-    -- In the future when GHCi is dynamically linked we should be able to relax
-    -- this, but they we may have to make it possible to load either ordinary
-    -- .o files or -dynamic .o files into GHCi (currently that's not possible
-    -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
-    -- whereas we have __stginit_base_Prelude_.
-      else if objectSuf dflags == normalObjectSuffix && not (null haskellWays)
-      then failNonStd dflags srcspan
-      else return $ Just $ if dynamicGhc
-                           then "dyn_o"
-                           else "o"
-    where haskellWays = filter (not . wayRTSOnly) (ways dflags)
+checkNonStdWay dflags srcspan
+  | interpWays == haskellWays = return Nothing
+    -- Only if we are compiling with the same ways as GHC is built
+    -- with, can we dynamically load those object files. (see #3604)
+
+  | objectSuf dflags == normalObjectSuffix && not (null haskellWays)
+  = failNonStd dflags srcspan
+
+  | otherwise = return (Just (interpTag ++ "o"))
+  where
+    haskellWays = filter (not . wayRTSOnly) (ways dflags)
+    interpTag = case mkBuildTag interpWays of
+                  "" -> ""
+                  tag -> tag ++ "_"
 
 normalObjectSuffix :: String
 normalObjectSuffix = phaseInputExt StopLn
@@ -529,11 +525,13 @@ normalObjectSuffix = phaseInputExt StopLn
 failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
 failNonStd dflags srcspan = dieWith dflags srcspan $
   ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
-  ptext (sLit "You need to build the program twice: once the") <+> ghciWay <+> ptext (sLit "way, and then") $$
+  ptext (sLit "You need to build the program twice: once") <+>
+  ghciWay <> ptext (sLit ", and then") $$
   ptext (sLit "in the desired way using -osuf to set the object file suffix.")
-    where ghciWay = if dynamicGhc
-                    then ptext (sLit "dynamic")
-                    else ptext (sLit "normal")
+    where ghciWay
+            | dynamicGhc = ptext (sLit "with -dynamic")
+            | rtsIsProfiled = ptext (sLit "with -prof")
+            | otherwise = ptext (sLit "the normal way")
 
 getLinkDeps :: HscEnv -> HomePackageTable
             -> PersistentLinkerState
@@ -663,7 +661,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
                 ok <- doesFileExist new_file
                 if (not ok)
                    then dieWith dflags span $
-                          ptext (sLit "cannot find normal object file ")
+                          ptext (sLit "cannot find object file ")
                                 <> quotes (text new_file) $$ while_linking_expr
                    else return (DotO new_file)
             adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)
@@ -1199,22 +1197,34 @@ locateLib dflags is_hs dirs lib
     --       for a dynamic library (#5289)
     --   otherwise, assume loadDLL can find it
     --
-  = findDll `orElse` findArchive `orElse` tryGcc `orElse` tryGccPrefixed `orElse` assumeDll
-
-  | not dynamicGhc
-    -- When the GHC package was not compiled as dynamic library
-    -- (=DYNAMIC not set), we search for .o libraries or, if they
-    -- don't exist, .a libraries.
-  = findObject `orElse` findArchive `orElse` assumeDll
+  = findDll `orElse`
+    findArchive `orElse`
+    tryGcc `orElse`
+    tryGccPrefixed `orElse`
+    assumeDll
 
-  | otherwise
+  | dynamicGhc
     -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
     -- we search for .so libraries first.
   = findHSDll `orElse` findDynObject `orElse` assumeDll
+
+  | rtsIsProfiled
+    -- When the GHC package is profiled, only a libHSfoo_p.a archive will do.
+  = findArchive `orElse`
+    assumeDll
+
+  | otherwise
+    -- HSfoo.o is the best, but only works for the normal way
+    -- libHSfoo.a is the backup option.
+  = findObject `orElse`
+    findArchive `orElse`
+    assumeDll
+
    where
      obj_file     = lib <.> "o"
      dyn_obj_file = lib <.> "dyn_o"
-     arch_file    = "lib" ++ lib <.> "a"
+     arch_file = "lib" ++ lib ++ lib_tag <.> "a"
+     lib_tag = if is_hs && rtsIsProfiled then "_p" else ""
 
      hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
      hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
index b95d053..6853fbb 100644 (file)
@@ -175,17 +175,17 @@ getClosureData :: DynFlags -> a -> IO Closure
 getClosureData dflags a =
    case unpackClosure# a of
      (# iptr, ptrs, nptrs #) -> do
-           let iptr'
-                | ghciTablesNextToCode =
-                   Ptr iptr
+           let iptr0 = Ptr iptr
+           let iptr1
+                | ghciTablesNextToCode = iptr0
                 | otherwise =
                    -- the info pointer we get back from unpackClosure#
                    -- is to the beginning of the standard info table,
                    -- but the Storable instance for info tables takes
                    -- into account the extra entry pointer when
                    -- !ghciTablesNextToCode, so we must adjust here:
-                   Ptr iptr `plusPtr` negate (wORD_SIZE dflags)
-           itbl <- peekItbl dflags iptr'
+                   iptr0 `plusPtr` negate (wORD_SIZE dflags)
+           itbl <- peekItbl dflags iptr1
            let tipe = readCType (BCI.tipe itbl)
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
@@ -193,7 +193,7 @@ getClosureData dflags a =
                               | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
            ASSERT(elems >= 0) return ()
            ptrsList `seq`
-            return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
+            return (Closure tipe iptr0 itbl ptrsList nptrs_data)
 
 readCType :: Integral a => a -> ClosureType
 readCType i
@@ -774,7 +774,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             return (Term my_ty (Right dc) a subTerms)
 
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
-      tipe_clos ->
+      tipe_clos -> do
+         traceTR (text "Unknown closure:" <+> ppr tipe_clos)
          return (Suspension tipe_clos my_ty a Nothing)
 
   -- insert NewtypeWraps around newtypes
index fb6265c..b870560 100644 (file)
@@ -172,10 +172,8 @@ import SrcLoc
 import BasicTypes       ( IntWithInf, treatZeroAsInf )
 import FastString
 import Outputable
-#ifdef GHCI
 import Foreign.C        ( CInt(..) )
 import System.IO.Unsafe ( unsafeDupablePerformIO )
-#endif
 import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
 
 import System.IO.Unsafe ( unsafePerformIO )
@@ -1580,9 +1578,10 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)
                        else []
 
 interpWays :: [Way]
-interpWays = if dynamicGhc
-             then [WayDyn]
-             else []
+interpWays
+  | dynamicGhc = [WayDyn]
+  | rtsIsProfiled = [WayProf]
+  | otherwise = []
 
 --------------------------------------------------------------------------
 
@@ -3493,14 +3492,12 @@ glasgowExtsFlags = [
            , Opt_UnicodeSyntax
            , Opt_UnliftedFFITypes ]
 
-#ifdef GHCI
 -- Consult the RTS to find whether GHC itself has been built profiled
 -- If so, you can't use Template Haskell
 foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt
 
 rtsIsProfiled :: Bool
 rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0
-#endif
 
 #ifdef GHCI
 -- Consult the RTS to find whether GHC itself has been built with
@@ -4126,6 +4123,8 @@ compilerInfo dflags
                                        then "YES" else "NO"),
        ("GHC Dynamic",                 if dynamicGhc
                                        then "YES" else "NO"),
+       ("GHC Profiled",                if rtsIsProfiled
+                                       then "YES" else "NO"),
        ("Leading underscore",          cLeadingUnderscore),
        ("Debug on",                    show debugIsOn),
        ("LibDir",                      topDir dflags),
@@ -4217,6 +4216,14 @@ makeDynFlagsConsistent dflags
            "Enabling -fPIC as it is always on for this platform"
  | Left err <- checkOptLevel (optLevel dflags) dflags
     = loop (updOptLevel 0 dflags) err
+
+ | LinkInMemory <- ghcLink dflags
+ , rtsIsProfiled
+ , isObjectTarget (hscTarget dflags)
+ , WayProf `notElem` ways dflags
+    = loop dflags{ways = WayProf : ways dflags}
+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"
+
  | otherwise = (dflags, [])
     where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")
           loop updated_dflags warning
index 95cb5f2..53c6f62 100644 (file)
@@ -1787,11 +1787,6 @@ hscCompileCoreExpr hsc_env =
 
 hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
 hscCompileCoreExpr' hsc_env srcspan ds_expr
-    | rtsIsProfiled
-    = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
-            -- Otherwise you get a seg-fault when you run it
-
-    | otherwise
     = do { let dflags = hsc_dflags hsc_env
 
            {- Simplify it -}
index 1153afa..21eff8f 100644 (file)
@@ -83,7 +83,6 @@ import Data.Maybe
 
 import Exception hiding (catch)
 
-import Foreign.C
 #if __GLASGOW_HASKELL__ >= 709
 import Foreign
 #else
@@ -346,8 +345,6 @@ findEditor = do
         return ""
 #endif
 
-foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
-
 default_progname, default_prompt, default_prompt2, default_stop :: String
 default_progname = "<interactive>"
 default_prompt = "%s> "
@@ -360,13 +357,6 @@ default_args = []
 interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
               -> Ghc ()
 interactiveUI config srcs maybe_exprs = do
-   -- although GHCi compiles with -prof, it is not usable: the byte-code
-   -- compiler and interpreter don't work with profiling.  So we check for
-   -- this up front and emit a helpful error message (#2197)
-   i <- liftIO $ isProfiled
-   when (i /= 0) $
-     throwGhcException (InstallationError "GHCi cannot be used when compiled with -prof")
-
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
index 74f18b8..607931d 100644 (file)
@@ -244,10 +244,12 @@ extern CostCentreStack * RTS_VAR(CCS_LIST);         // registered CCS list
 
 /* eliminate profiling overhead from allocation costs */
 #define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
+#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs
 
 #else /* !PROFILING */
 
 #define CCS_ALLOC(ccs, amount) doNothing()
+#define ENTER_CCS_THUNK(cap,p) doNothing()
 
 #endif /* PROFILING */
 
index 3890d49..228369b 100644 (file)
@@ -49,28 +49,6 @@ typedef struct {
 } StgProfInfo;
 
 /* -----------------------------------------------------------------------------
-   Ticky info
-
-   There is no ticky-specific stuff in an info table at this time.
-   -------------------------------------------------------------------------- */
-
-/* -----------------------------------------------------------------------------
-   Debugging info
-   -------------------------------------------------------------------------- */
-
-#ifdef DEBUG_CLOSURE
-
-typedef struct {
-        ... whatever ...
-} StgDebugInfo;
-
-#else /* !DEBUG_CLOSURE */
-
-/* There is no DEBUG-specific stuff in an info table at this time. */
-
-#endif /* DEBUG_CLOSURE */
-
-/* -----------------------------------------------------------------------------
    Closure flags
    -------------------------------------------------------------------------- */
 
@@ -216,12 +194,6 @@ typedef struct StgInfoTable_ {
 #ifdef PROFILING
     StgProfInfo     prof;
 #endif
-#ifdef TICKY
-  /* Ticky-specific stuff would go here. */
-#endif
-#ifdef DEBUG_CLOSURE
-  /* Debug-specific stuff would go here. */
-#endif
 
     StgClosureInfo  layout;     /* closure layout info (one word) */
 
index 573e499..3ad3bc6 100644 (file)
@@ -340,6 +340,8 @@ eval_obj:
             RETURN_TO_SCHEDULER(ThreadInterpret, StackOverflow);
         }
 
+        ENTER_CCS_THUNK(cap,ap);
+
         /* Ok; we're safe.  Party on.  Push an update frame. */
         Sp -= sizeofW(StgUpdateFrame);
         {
@@ -529,7 +531,7 @@ do_return_unboxed:
         // get the offset of the stg_ctoi_ret_XXX itbl
         offset = stack_frame_sizeW((StgClosure *)Sp);
 
-        switch (get_itbl((StgClosure *)Sp+offset)->type) {
+        switch (get_itbl((StgClosure*)((StgPtr)Sp+offset))->type) {
 
         case RET_BCO:
             // Returning to an interpreted continuation: put the object on
@@ -883,7 +885,7 @@ run_BCO:
                   // the BCO
                   size_words = BCO_BITMAP_SIZE(obj) + 2;
                   new_aps = (StgAP_STACK *) allocate(cap, AP_STACK_sizeW(size_words));
-                  SET_HDR(new_aps,&stg_AP_STACK_info,CCS_SYSTEM);
+                  SET_HDR(new_aps,&stg_AP_STACK_info,cap->r.rCCCS);
                   new_aps->size = size_words;
                   new_aps->fun = &stg_dummy_ret_closure;
 
@@ -1098,7 +1100,7 @@ run_BCO:
             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
             Sp[-1] = (W_)ap;
             ap->n_args = n_payload;
-            SET_HDR(ap, &stg_AP_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(ap, &stg_AP_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1109,7 +1111,7 @@ run_BCO:
             ap = (StgAP*)allocate(cap, AP_sizeW(n_payload));
             Sp[-1] = (W_)ap;
             ap->n_args = n_payload;
-            SET_HDR(ap, &stg_AP_NOUPD_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(ap, &stg_AP_NOUPD_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1122,7 +1124,7 @@ run_BCO:
             Sp[-1] = (W_)pap;
             pap->n_args = n_payload;
             pap->arity = arity;
-            SET_HDR(pap, &stg_PAP_info, CCS_SYSTEM/*ToDo*/)
+            SET_HDR(pap, &stg_PAP_info, cap->r.rCCCS)
             Sp --;
             goto nextInsn;
         }
@@ -1192,7 +1194,7 @@ run_BCO:
                                                itbl->layout.payload.nptrs );
             StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
             ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
-            SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), CCS_SYSTEM/*ToDo*/);
+            SET_HDR(con, (StgInfoTable*)BCO_LIT(o_itbl), cap->r.rCCCS);
             for (i = 0; i < n_words; i++) {
                 con->payload[i] = (StgClosure*)Sp[i];
             }
index fb76539..0507c9c 100644 (file)
@@ -31,6 +31,7 @@
 #include "GetEnv.h"
 #include "Stable.h"
 #include "RtsSymbols.h"
+#include "Profiling.h"
 
 #if !defined(mingw32_HOST_OS)
 #include "posix/Signals.h"
@@ -1831,9 +1832,15 @@ static HsInt loadArchive_ (pathchar *path)
         IF_DEBUG(linker,
                  debugBelch("loadArchive: Found member file `%s'\n", fileName));
 
-        isObject = thisFileNameSize >= 2
-                && fileName[thisFileNameSize - 2] == '.'
-                && fileName[thisFileNameSize - 1] == 'o';
+        isObject =
+               (thisFileNameSize >= 2 &&
+                fileName[thisFileNameSize - 2] == '.' &&
+                fileName[thisFileNameSize - 1] == 'o')
+            || (thisFileNameSize >= 4 &&
+                fileName[thisFileNameSize - 4] == '.' &&
+                fileName[thisFileNameSize - 3] == 'p' &&
+                fileName[thisFileNameSize - 2] == '_' &&
+                fileName[thisFileNameSize - 1] == 'o');
 
         IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize));
         IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject));
@@ -2260,6 +2267,12 @@ static HsInt resolveObjs_ (void)
             oc->status = OBJECT_RESOLVED;
         }
     }
+
+#ifdef PROFILING
+    // collect any new cost centres & CCSs that were defined during runInit
+    initProfiling2();
+#endif
+
     IF_DEBUG(linker, debugBelch("resolveObjs: done\n"));
     return 1;
 }
index f44519d..7d0c661 100644 (file)
@@ -1960,8 +1960,6 @@ stg_mkApUpd0zh ( P_ bco )
 
 stg_unpackClosurezh ( P_ closure )
 {
-// TODO: Consider the absence of ptrs or nonptrs as a special case ?
-
     W_ info, ptrs, nptrs, p, ptrs_arr, nptrs_arr;
     info  = %GET_STD_INFO(UNTAG(closure));
 
index 0259a19..bfb8aaa 100644 (file)
@@ -311,7 +311,7 @@ nextEra( void )
 FILE *hp_file;
 static char *hp_filename;
 
-void initProfiling1 (void)
+void initProfiling (void)
 {
 }
 
index 23a4899..982b946 100644 (file)
@@ -142,8 +142,7 @@ static  void              initProfilingLogFile ( void );
    Initialise the profiling environment
    -------------------------------------------------------------------------- */
 
-void
-initProfiling1 (void)
+void initProfiling (void)
 {
     // initialise our arena
     prof_arena = newArena();
@@ -159,18 +158,6 @@ initProfiling1 (void)
 #ifdef THREADED_RTS
     initMutex(&ccs_mutex);
 #endif
-}
-
-void
-freeProfiling (void)
-{
-    arenaFree(prof_arena);
-}
-
-void
-initProfiling2 (void)
-{
-    CostCentreStack *ccs, *next;
 
     /* Set up the log file, and dump the header and cost centre
      * information into it.
@@ -205,14 +192,7 @@ initProfiling2 (void)
     CCS_MAIN->root = CCS_MAIN;
     ccsSetSelected(CCS_MAIN);
 
-    // make CCS_MAIN the parent of all the pre-defined CCSs.
-    for (ccs = CCS_LIST; ccs != NULL; ) {
-        next = ccs->prevStack;
-        ccs->prevStack = NULL;
-        actualPush_(CCS_MAIN,ccs->cc,ccs);
-        ccs->root = ccs;
-        ccs = next;
-    }
+    initProfiling2();
 
     if (RtsFlags.CcFlags.doCostCentres) {
         initTimeProfiling();
@@ -223,6 +203,29 @@ initProfiling2 (void)
     }
 }
 
+//
+// Should be called after loading any new Haskell code.
+//
+void initProfiling2 (void)
+{
+    CostCentreStack *ccs, *next;
+
+    // make CCS_MAIN the parent of all the pre-defined CCSs.
+    for (ccs = CCS_LIST; ccs != NULL; ) {
+        next = ccs->prevStack;
+        ccs->prevStack = NULL;
+        actualPush_(CCS_MAIN,ccs->cc,ccs);
+        ccs->root = ccs;
+        ccs = next;
+    }
+    CCS_LIST = NULL;
+}
+
+void
+freeProfiling (void)
+{
+    arenaFree(prof_arena);
+}
 
 static void
 initProfilingLogFile(void)
index 8c36522..4158020 100644 (file)
@@ -20,7 +20,7 @@
 #define PROFILING_ONLY(s) doNothing()
 #endif
 
-void initProfiling1 (void);
+void initProfiling  (void);
 void initProfiling2 (void);
 void endProfiling   (void);
 void freeProfiling  (void);
index 584c31e..35e52aa 100644 (file)
@@ -230,7 +230,7 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     initThreadLabelTable();
 #endif
 
-    initProfiling1();
+    initProfiling();
 
     /* start the virtual timer 'subsystem'. */
     initTimer();
@@ -255,10 +255,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
 
     startupHpc();
 
-    // This must be done after module initialisation.
-    // ToDo: make this work in the presence of multiple hs_add_root()s.
-    initProfiling2();
-
     // ditto.
 #if defined(THREADED_RTS)
     ioManagerStart();
index 5692550..3a43557 100644 (file)
       SymI_HasProto(stg_INTLIKE_closure)
 #endif
 
+#if defined(PROFILING)
+#define RTS_PROF_SYMBOLS                        \
+      SymI_HasProto(CCS_DONT_CARE)              \
+      SymI_HasProto(CC_LIST)                    \
+      SymI_HasProto(CC_ID)                      \
+      SymI_HasProto(CCS_LIST)                   \
+      SymI_HasProto(CCS_ID)                     \
+      SymI_HasProto(stg_restore_cccs_info)      \
+      SymI_HasProto(enterFunCCS)                \
+      SymI_HasProto(pushCostCentre)             \
+      SymI_HasProto(era)
+#else
+#define RTS_PROF_SYMBOLS /* empty */
+#endif
 
 #define RTS_SYMBOLS                                                     \
       Maybe_Stable_Names                                                \
       RTS_TICKY_SYMBOLS                                                 \
+      RTS_PROF_SYMBOLS                                                  \
       SymI_HasProto(StgReturn)                                          \
       SymI_HasProto(stg_gc_noregs)                                      \
       SymI_HasProto(stg_ret_v_info)                                     \
index 55a6a73..fdb7250 100644 (file)
@@ -179,7 +179,6 @@ def get_compiler_info():
 
     if re.match(".*_p(_.*|$)", rtsInfoDict["RTS way"]):
         config.compiler_profiled = True
-        config.run_ways = [x for x in config.run_ways if x != 'ghci']
     else:
         config.compiler_profiled = False
 
@@ -204,6 +203,11 @@ def get_compiler_info():
         config.ghci_way_flags   = "-dynamic"
         config.ghc_th_way       = "dyn"
         config.ghc_plugin_way   = "dyn"
+    elif config.compiler_profiled:
+        config.ghc_th_way_flags = "-prof"
+        config.ghci_way_flags   = "-prof"
+        config.ghc_th_way       = "prof"
+        config.ghc_plugin_way   = "prof"
     else:
         config.ghc_th_way_flags = "-static"
         config.ghci_way_flags   = "-static"
index 055c856..3039879 100644 (file)
@@ -250,6 +250,10 @@ ifeq "$(GhcDynamic)" "YES"
 ghcThWayFlags     = -dynamic
 ghciWayFlags      = -dynamic
 ghcPluginWayFlags = -dynamic
+else ifeq "$(GhcProfiled)" "YES"
+ghcThWayFlags     = -prof
+ghciWayFlags      = -prof
+ghcPluginWayFlags = -prof
 else
 ghcThWayFlags     = -static
 ghciWayFlags      = -static
index c5ad5ff..4ca3d30 100644 (file)
@@ -25,6 +25,7 @@ main = do
   getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
   getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
   getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
+  getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
   getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
   getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
 
index 1c6690b..57efc26 100644 (file)
@@ -1,6 +1,3 @@
-
-setTestOpts(when(compiler_profiled(), skip))
-
 # Annotations, like Template Haskell, require runtime evaluation.  In
 # order for this to work with profiling, we would have to build the
 # program twice and use -osuf p_o (see the TH_splitE5_prof test).  For
index 4159eee..b10fc72 100644 (file)
@@ -5,7 +5,7 @@ include $(TOP)/mk/test.mk
 annth_make:
        $(MAKE) clean_annth_make
        mkdir build_make
-       '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make \
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 --make \
           -odir build_make -hidir build_make -o build_make/annth annth.hs
 
 clean_annth_make:
@@ -14,16 +14,16 @@ clean_annth_make:
 annth_compunits:
        $(MAKE) clean_annth_compunits
        mkdir build_compunits
-       '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -dynamic-too \
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 \
          -odir build_compunits -hidir build_compunits \
          -c AnnHelper.hs
-       '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -dynamic-too \
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 \
          -odir build_compunits -hidir build_compunits \
          -c TestModule.hs
-       '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -dynamic-too \
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 \
          -odir build_compunits -hidir build_compunits \
          -c TestModuleTH.hs
-       '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -ibuild_compunits \
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -ibuild_compunits \
          -odir build_compunits -hidir build_compunits \
          -c annth.hs
 
index b44a0d5..a1681cf 100644 (file)
@@ -1,5 +1,3 @@
-setTestOpts(when(compiler_profiled(), skip))
-
 # Annotations and Template Haskell, require runtime evaluation.  In
 # order for this to work with profiling, we would have to build the
 # program twice and use -osuf p_o (see the TH_splitE5_prof test).  For
index de5d4d3..8cc3a24 100644 (file)
@@ -6,6 +6,7 @@ import Language.Haskell.TH.Syntax
 import AnnHelper
 import TestModule
 import TestModuleTH
+import System.IO
 
 main = do
   $(do
@@ -24,3 +25,4 @@ main = do
     anns <- reifyAnnotations (AnnLookupName 'TestTypeTH)
     runIO $ print (anns :: [String])
     [| return () |] )
+  hFlush stdout
index db01b25..183ff97 100644 (file)
@@ -1,4 +1,3 @@
-setTestOpts(when(compiler_profiled(), skip))
 # These tests are very slow due to their use of package GHC
 setTestOpts(when(fast(), skip))
 
index 34845ff..9aaa25f 100644 (file)
@@ -14,7 +14,7 @@ cabal04:
        $(MAKE) clean
        '$(TEST_HC)' -v0 --make Setup
        $(SETUP) clean
-       $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' $(VANILLA) $(PROF) $(DYN)
+       $(SETUP) configure --with-ghc='$(TEST_HC)' --ghc-options='$(filter-out -rtsopts,$(TEST_HC_OPTS))' $(VANILLA) $(PROF) $(DYN) --ghc-options='$(ghcThWayFlags)'
        $(SETUP) build 2> err
        ! grep -v "Creating library file" err
 ifneq "$(CLEANUP)" ""
index 6d9d13d..53d9014 100644 (file)
@@ -8,7 +8,7 @@ if config.have_profiling:
 else:
     prof = '--disable-library-profiling'
 
-if config.have_shared_libs:
+if not config.compiler_profiled and config.have_shared_libs:
     dyn = '--enable-shared'
 else:
     dyn = '--disable-shared'
index d5400bf..8cb6d9a 100644 (file)
@@ -1,5 +1,3 @@
-setTestOpts(when(compiler_profiled(), skip))
-
 test('T7962', [exit_code(2), req_interp, ignore_output], run_command,
      ['$MAKE --no-print-directory -s T7962'])
 
index 0e6f7f9..dcb7207 100644 (file)
@@ -1,6 +1,4 @@
 
-setTestOpts(when(compiler_profiled(), skip))
-
 test('ghc-e001', req_interp, run_command, ['$MAKE --no-print-directory -s ghc-e001'])
 test('ghc-e002', req_interp, run_command, ['$MAKE --no-print-directory -s ghc-e002'])
 test('ghc-e003', req_interp, run_command, ['$MAKE --no-print-directory -s ghc-e003'])
index f8a0541..28089a2 100644 (file)
@@ -1,5 +1,4 @@
 setTestOpts([extra_run_opts('-ignore-dot-ghci'),
-             when(compiler_profiled(), skip),
              normalise_slashes])
 
 test('print001', normal, ghci_script, ['print001.script'])
index 497ad7e..546a8f4 100644 (file)
@@ -1,4 +1,3 @@
 setTestOpts(extra_run_opts('-ignore-dot-ghci'))
-setTestOpts(when(compiler_profiled(), skip))
 
 test('break022', extra_clean(['A.hs']), ghci_script, ['break022.script'])
index 22b608e..ac747d4 100644 (file)
@@ -1,4 +1,3 @@
 setTestOpts(extra_run_opts('-ignore-dot-ghci'))
-setTestOpts(when(compiler_profiled(), skip))
 
 test('break023', extra_clean(['A.hs']), ghci_script, ['break023.script'])
index d58b2dc..283251c 100755 (executable)
@@ -1,7 +1,5 @@
 # coding=utf8
 
-setTestOpts(when(compiler_profiled(), skip))
-
 test('ghci001', combined_output, ghci_script, ['ghci001.script'])
 test('ghci002', combined_output, ghci_script, ['ghci002.script'])
 test('ghci003', combined_output, ghci_script, ['ghci003.script'])
index 188975a..58a396e 100644 (file)
@@ -1,4 +1,2 @@
-setTestOpts(when(compiler_profiled(), skip))
-
 test('T10549', [], ghci_script, ['T10549.script'])
 test('T10549a', [], ghci_script, ['T10549a.script'])
index cd5b1f2..bcb1538 100644 (file)
@@ -1,6 +1,4 @@
 
-setTestOpts(when(compiler_profiled(), skip))
-
 # We only want to run these tests with GHCi
 def just_ghci( name, opts ):
   opts.only_ways = ['ghci']
index 0b973de..ddd53ee 100644 (file)
@@ -31,8 +31,7 @@ test('layout006',
 
 test('layout007',
      [req_interp,
-      extra_clean(['layout007.hi', 'layout007.o']),
-      when(compiler_profiled(), skip)],
+      extra_clean(['layout007.hi', 'layout007.o'])],
      run_command,
      ['$MAKE -s --no-print-directory layout007'])
 
index 013e34e..f114c0f 100644 (file)
@@ -1,3 +1 @@
-setTestOpts(when(compiler_profiled(), skip))
-
 test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
index 9e7b8a7..e99a414 100644 (file)
@@ -48,9 +48,9 @@ test('TypeFamilyInstanceLHS', normal, compile, ['-ddump-types -fno-warn-partial-
 test('Uncurry', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('UncurryNamed', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('WarningWildcardInstantiations', normal, compile, ['-ddump-types'])
-test('SplicesUsed', [req_interp, only_compiler_types(['ghc']), when(compiler_profiled(), skip),
+test('SplicesUsed', [req_interp, only_compiler_types(['ghc']),
                      extra_clean(['Splices.o', 'Splices.hi'])],
-     multimod_compile, ['SplicesUsed', ''])
+     multimod_compile, ['SplicesUsed', config.ghc_th_way_flags])
 test('TypedSplice', [req_interp, normal], compile, [''])
 test('T10403', normal, compile, [''])
 test('T10438', normal, compile, [''])
index bebd8bd..913b7d8 100644 (file)
@@ -5,11 +5,11 @@ test('ExtraConstraintsWildcardInExpressionSignature', normal, compile_fail, ['']
 test('ExtraConstraintsWildcardInPatternSignature', normal, compile_fail, [''])
 test('ExtraConstraintsWildcardInPatternSplice', normal, compile_fail, [''])
 test('ExtraConstraintsWildcardInTypeSpliceUsed',
-     [req_interp, when(compiler_profiled(), skip),
+     [req_interp,
       extra_clean(['ExtraConstraintsWildcardInTypeSplice.o', 'ExtraConstraintsWildcardInTypeSplice.hi'])],
-     multimod_compile_fail, ['ExtraConstraintsWildcardInTypeSpliceUsed', ''])
+     multimod_compile_fail, ['ExtraConstraintsWildcardInTypeSpliceUsed', config.ghc_th_way_flags])
 test('ExtraConstraintsWildcardInTypeSplice2',
-     [req_interp, when(compiler_profiled(), skip)],
+     req_interp,
      compile_fail, [''])
 test('ExtraConstraintsWildcardNotEnabled', normal, compile_fail, [''])
 test('ExtraConstraintsWildcardNotLast', normal, compile_fail, [''])
index 7d957d0..ad54f75 100644 (file)
@@ -13,6 +13,6 @@ package.%:
        mkdir pkg.$*
        "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
        "$(GHC_PKG)" init pkg.$*/local.package.conf
-       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" $(if $(findstring _p,$(GhcRTSWays)), --enable-library-profiling) --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
        pkg.$*/setup build     --distdir pkg.$*/dist -v0
        pkg.$*/setup install   --distdir pkg.$*/dist -v0
index 7d957d0..a78ba1d 100644 (file)
@@ -13,6 +13,6 @@ package.%:
        mkdir pkg.$*
        "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
        "$(GHC_PKG)" init pkg.$*/local.package.conf
-       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring _p,$(GhcRTSWays)), --enable-library-profiling)
        pkg.$*/setup build     --distdir pkg.$*/dist -v0
        pkg.$*/setup install   --distdir pkg.$*/dist -v0
index eb7cc6a..ed51533 100644 (file)
@@ -15,6 +15,6 @@ package.%:
        
        "$(GHC_PKG)" init pkg.$*/local.package.conf
        
-       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+       pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring _p,$(GhcRTSWays)), --enable-library-profiling)
        pkg.$*/setup build     --distdir pkg.$*/dist -v0
        pkg.$*/setup install   --distdir pkg.$*/dist -v0
index 5fd43b9..98f48fd 100644 (file)
@@ -1,36 +1,46 @@
-       Thu Apr  2 20:30 2015 Time and Allocation Profiling Report  (Final)
+       Fri Oct 30 17:14 2015 Time and Allocation Profiling Report  (Final)
 
           ioprof +RTS -hc -p -RTS
 
        total time  =        0.00 secs   (0 ticks @ 1000 us, 1 processor)
-       total alloc =      52,224 bytes  (excludes profiling overheads)
+       total alloc =      63,680 bytes  (excludes profiling overheads)
 
 COST CENTRE MODULE            %time %alloc
 
-MAIN        MAIN                0.0    1.4
-CAF         GHC.IO.Handle.FD    0.0   66.1
-CAF         GHC.IO.Encoding     0.0    6.3
-CAF         GHC.Conc.Signal     0.0    1.3
-main        Main                0.0   16.7
-errorM.\    Main                0.0    6.9
+CAF         GHC.IO.Handle.FD    0.0   54.2
+CAF         GHC.IO.Encoding     0.0    5.2
+CAF         GHC.Exception       0.0    1.2
+CAF         GHC.Conc.Signal     0.0    1.0
+main        Main                0.0   13.6
+errorM.\    Main                0.0   19.8
+CAF         Main                0.0    2.6
 
 
-                                                           individual      inherited
-COST CENTRE       MODULE                no.     entries  %time %alloc   %time %alloc
+                                                            individual      inherited
+COST CENTRE        MODULE                no.     entries  %time %alloc   %time %alloc
 
-MAIN              MAIN                   98           0    0.0    1.4     0.0  100.0
- main             Main                  197           0    0.0   16.5     0.0   16.5
- CAF              Main                  195           0    0.0    0.0     0.0    7.5
-  main            Main                  196           1    0.0    0.2     0.0    7.5
-   runM           Main                  198           1    0.0    0.3     0.0    7.3
-    bar           Main                  199           1    0.0    0.0     0.0    7.0
-     >>=          Main                  200           1    0.0    0.0     0.0    6.9
-      >>=.\       Main                  201           1    0.0    0.0     0.0    6.9
-       foo        Main                  202           1    0.0    0.0     0.0    6.9
-        errorM    Main                  203           1    0.0    0.0     0.0    6.9
-         errorM.\ Main                  204           1    0.0    6.9     0.0    6.9
- CAF              GHC.Conc.Signal       177           0    0.0    1.3     0.0    1.3
- CAF              GHC.Conc.Sync         176           0    0.0    0.4     0.0    0.4
- CAF              GHC.IO.Encoding       161           0    0.0    6.3     0.0    6.3
- CAF              GHC.IO.Encoding.Iconv 159           0    0.0    0.4     0.0    0.4
- CAF              GHC.IO.Handle.FD      150           0    0.0   66.1     0.0   66.1
+MAIN               MAIN                  102           0    0.0    1.0     0.0  100.0
+ main              Main                  205           0    0.0   13.5     0.0   13.5
+ CAF               Main                  203           0    0.0    2.6     0.0   23.2
+  fmap             Main                  212           1    0.0    0.0     0.0    0.0
+  <*>              Main                  208           1    0.0    0.0     0.0    0.0
+  main             Main                  204           1    0.0    0.2     0.0   20.6
+   runM            Main                  206           1    0.0    0.3     0.0   20.4
+    bar            Main                  207           1    0.0    0.2     0.0   20.1
+     foo           Main                  216           1    0.0    0.0     0.0    0.0
+      errorM       Main                  217           1    0.0    0.0     0.0    0.0
+     fmap          Main                  213           0    0.0    0.0     0.0    0.0
+      >>=          Main                  214           1    0.0    0.0     0.0    0.0
+     <*>           Main                  209           0    0.0    0.0     0.0   19.8
+      >>=          Main                  210           1    0.0    0.0     0.0   19.8
+       >>=.\       Main                  211           2    0.0    0.0     0.0   19.8
+        foo        Main                  218           0    0.0    0.0     0.0   19.8
+         errorM    Main                  219           0    0.0    0.0     0.0   19.8
+          errorM.\ Main                  220           1    0.0   19.8     0.0   19.8
+        fmap       Main                  215           0    0.0    0.0     0.0    0.0
+ CAF               GHC.Conc.Signal       197           0    0.0    1.0     0.0    1.0
+ CAF               GHC.Conc.Sync         196           0    0.0    0.4     0.0    0.4
+ CAF               GHC.Exception         194           0    0.0    1.2     0.0    1.2
+ CAF               GHC.IO.Encoding       187           0    0.0    5.2     0.0    5.2
+ CAF               GHC.IO.Encoding.Iconv 185           0    0.0    0.4     0.0    0.4
+ CAF               GHC.IO.Handle.FD      177           0    0.0   54.2     0.0   54.2
index e31a732..79eb3b9 100644 (file)
@@ -7,6 +7,6 @@ TH_QQ:
 ifeq "$(GhcDynamic)" "YES"
        '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs -dynamic -osuf dyn_o -hisuf dyn_hi
 else
-       '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -c QQ.hs
 endif
 
index 0b4448c..4d6767d 100644 (file)
@@ -4,4 +4,4 @@ test('qq007',
       pre_cmd('$MAKE -s --no-print-directory TH_QQ'),
       ],
      multimod_compile,
-     ['Test', '-v0'])
+     ['Test', '-v0 ' + config.ghc_th_way_flags])
index e31a732..79eb3b9 100644 (file)
@@ -7,6 +7,6 @@ TH_QQ:
 ifeq "$(GhcDynamic)" "YES"
        '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs -dynamic -osuf dyn_o -hisuf dyn_hi
 else
-       '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -c QQ.hs
 endif
 
index 8cac1a9..cb1feae 100644 (file)
@@ -4,4 +4,4 @@ test('qq008',
       pre_cmd('$MAKE -s --no-print-directory TH_QQ'),
       ],
      multimod_compile,
-     ['Test', '-v0'])
+     ['Test', '-v0 ' + config.ghc_th_way_flags])
index 0fa91db..f3fb673 100644 (file)
@@ -7,5 +7,5 @@ TH_QQ:
 ifeq "$(GhcDynamic)" "YES"
        '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs -dynamic -osuf dyn_o -hisuf dyn_hi
 else
-       '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -c QQ.hs
 endif
index 10b939a..7ad1ebe 100644 (file)
@@ -4,4 +4,4 @@ test('qq009',
       pre_cmd('$MAKE -s --no-print-directory TH_QQ'),
       ],
      multimod_compile,
-     ['Test', '-v0'])
+     ['Test', '-v0 ' + config.ghc_th_way_flags])
index d268f2e..3ffaa20 100644 (file)
@@ -1,6 +1,3 @@
-
-setTestOpts(when(compiler_profiled(), skip))
-
 test('T7859', req_interp, run_command,
      ['$MAKE --no-print-directory -s T7859'])
 
index d219e80..5d2be1e 100644 (file)
@@ -16,7 +16,7 @@ HC_OPTS = -XTemplateHaskell -package template-haskell
 
 TH_spliceE5_prof::
        $(RM) TH_spliceE5_prof*.o TH_spliceE5_prof*.hi TH_spliceE5_prof*.p.o 
-       '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof.hs -c
+       '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) $(ghcThWayFlags) --make -v0 TH_spliceE5_prof.hs -c
        '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof.hs -prof -auto-all -osuf p.o -o $@
        ./$@
 
index 77709c2..5dd9291 100644 (file)
@@ -1,5 +1,3 @@
-setTestOpts(when(compiler_profiled(), skip))
-
 test('T2014',
      [req_interp,
       extra_clean(['A.hi-boot','A.hi','A.o','A.o-boot',
diff --git a/testsuite/tests/th/T4255.hs b/testsuite/tests/th/T4255.hs
deleted file mode 100644 (file)
index 8509f0e..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-
-{-# LANGUAGE TemplateHaskell #-}
-module T4255 where
-
-f x = $([| x |])
diff --git a/testsuite/tests/th/T4255.stderr b/testsuite/tests/th/T4255.stderr
deleted file mode 100644 (file)
index e2c4f2f..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-ghc: T4255.hs:2:14-28: You can't use Template Haskell with a profiled compiler
-Usage: For basic information, try the `--help' option.
index 8a4a180..770c75c 100644 (file)
@@ -1,6 +1,4 @@
 
-setTestOpts(when(compiler_profiled(), skip))
-
 test('TH_import_loop',
      [extra_clean(['ModuleA.o-boot', 'ModuleA.hi-boot',
                    'ModuleC.o', 'ModuleC.hi']),
index 3d08f36..2a040f2 100644 (file)
@@ -4,10 +4,6 @@
 # and no splices, consider adding it to the quotes/ directory instead
 # of the th/ directory; this way, we can test it on the stage 1 compiler too!
 
-# This test needs to come before the setTestOpts calls below, as we want
-# to run it if compiler_profiled.
-test('T4255', unless(compiler_profiled(), skip), compile_fail, ['-v0'])
-
 def f(name, opts):
     opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
     if (ghc_with_interpreter == 0):
@@ -15,7 +11,6 @@ def f(name, opts):
 
 setTestOpts(f)
 setTestOpts(only_ways(['normal','ghci']))
-setTestOpts(when(compiler_profiled(), skip))
 
 test('TH_mkName', normal, compile, ['-v0'])
 test('TH_1tuple', normal, compile_fail, ['-v0'])
@@ -130,7 +125,7 @@ test('TH_linePragma', normal, compile_fail, ['-v0'])
 test('T1830_3',
      extra_clean(['T1830_3a.o','T1830_3a.hi']),
      multimod_compile_and_run,
-     ['T1830_3', '-v0'])
+     ['T1830_3', '-v0 ' + config.ghc_th_way_flags])
 test('T2700', normal, compile, ['-v0'])
 test('T2817', normal, compile, ['-v0'])
 test('T2713', normal, compile_fail, ['-v0'])
@@ -320,7 +315,8 @@ test('TH_StaticPointers02',
      compile_fail, [''])
 test('T8759', normal, compile_fail, ['-v0'])
 test('T7021',
-     extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile, ['T7021','-v0'])
+     extra_clean(['T7021a.hi', 'T7021a.o']), multimod_compile,
+     ['T7021','-v0 ' + config.ghc_th_way_flags])
 test('T8807', normal, compile, ['-v0'])
 test('T8884', normal, compile, ['-v0'])
 test('T8954', normal, compile, ['-v0'])
@@ -348,7 +344,7 @@ test('T10047', normal, ghci_script, ['T10047.script'])
 test('T10019', normal, ghci_script, ['T10019.script'])
 test('T10267', extra_clean(['T10267a.hi', 'T10267a.o']),
                multimod_compile_fail,
-               ['T10267', '-dsuppress-uniques -v0'])
+               ['T10267', '-dsuppress-uniques -v0 ' + config.ghc_th_way_flags])
 test('T10279', normal, compile_fail, ['-v0'])
 test('T10306', normal, compile, ['-v0'])
 test('T10596', normal, compile, ['-v0'])
@@ -357,7 +353,7 @@ test('T10638', normal, compile_fail, ['-v0'])
 test('T10704',
      extra_clean(['T10704a.o','T10704a.hi']),
      multimod_compile_and_run,
-     ['T10704', '-v0'])
+     ['T10704', '-v0 ' + config.ghc_th_way_flags])
 test('T6018th', normal, compile_fail, ['-v0'])
 test('TH_namePackage', normal, compile_and_run, ['-v0'])
 test('TH_nameSpace', normal, compile_and_run, ['-v0'])