Make GHCi & TH work when the compiler is built with -prof

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

7 files changed, 88 insertions, 62 deletions

diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index ce8b9f8b6b..723f7fc4cc 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -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
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index a7384c725b..efad805120 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -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
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index a01fcd89b9..01420f5e34 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -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
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index f62998ce86..9fa89fec5e 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -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
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index b95d05322f..6853fbbaea 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fb6265cdfb..b8705603c7 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 95cb5f222f..53c6f626e5 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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 -}