[commit: ghc] master: Add trace injection (12efb23)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/12efb230de40f24e4828734dd46627ebe24416b4/ghc

>---------------------------------------------------------------

commit 12efb230de40f24e4828734dd46627ebe24416b4
Author: David Feuer <david.feuer at gmail.com>
Date:   Fri Dec 1 15:59:24 2017 -0500

    Add trace injection
    
    Add support for injecting runtime calls to `trace` in `DsM`. This
    allows the desugarer to add compile-time information to a runtime
    trace.
    
    Reviewers: austin, hvr, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: carter, thomie, rwbarton
    
    Differential Revision: https://phabricator.haskell.org/D4162


>---------------------------------------------------------------

12efb230de40f24e4828734dd46627ebe24416b4
 compiler/deSugar/DsMonad.hs        | 34 ++++++++++++++++-
 compiler/prelude/PrelNames.hs      | 12 +++++-
 libraries/base/Debug/Trace.hs-boot | 76 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 119 insertions(+), 3 deletions(-)

diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 1eabf02..ae39e3d 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -49,7 +49,10 @@ module DsMonad (
         CanItFail(..), orFail,
 
         -- Levity polymorphism
-        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+
+        -- Trace injection
+        pprRuntimeTrace
     ) where
 
 import GhcPrelude
@@ -87,6 +90,7 @@ import Maybes
 import Var (EvVar)
 import qualified GHC.LanguageExtensions as LangExt
 import UniqFM ( lookupWithDefaultUFM )
+import Literal ( mkMachString )
 
 import Data.IORef
 import Control.Monad
@@ -732,3 +736,31 @@ dsLookupDPHRdrEnv_maybe occ
            _     -> pprPanic multipleNames (ppr occ)
        }
   where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
+
+-- | Inject a trace message into the compiled program. Whereas
+-- pprTrace prints out information *while compiling*, pprRuntimeTrace
+-- captures that information and causes it to be printed *at runtime*
+-- using Debug.Trace.trace.
+--
+--   pprRuntimeTrace hdr doc expr
+--
+-- will produce an expression that looks like
+--
+--   trace (hdr + doc) expr
+--
+-- When using this to debug a module that Debug.Trace depends on,
+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
+-- but that doesn't seem worth the effort and maintenance cost.
+pprRuntimeTrace :: String   -- ^ header
+                -> SDoc     -- ^ information to output
+                -> CoreExpr -- ^ expression
+                -> DsM CoreExpr
+pprRuntimeTrace str doc expr = do
+  traceId <- dsLookupGlobalId traceName
+  unpackCStringId <- dsLookupGlobalId unpackCStringName
+  dflags <- getDynFlags
+  let message :: CoreExpr
+      message = App (Var unpackCStringId) $
+                Lit $ mkMachString $ showSDoc dflags (hang (text str) 4 doc)
+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index ae695d4..f418348 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -332,7 +332,7 @@ basicKnownKeyNames
         otherwiseIdName, inlineIdName,
         eqStringName, assertName, breakpointName, breakpointCondName,
         breakpointAutoName,  opaqueTyConName,
-        assertErrorName,
+        assertErrorName, traceName,
         printName, fstName, sndName,
 
         -- Integer
@@ -481,7 +481,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,
     aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
     cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,
-    dATA_COERCE :: Module
+    dATA_COERCE, dEBUG_TRACE :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
@@ -539,6 +539,7 @@ gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")
 gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")
 dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality")
 dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")
+dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")
 
 gHC_PARR' :: Module
 gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
@@ -1320,6 +1321,10 @@ dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey
 assertErrorName    :: Name
 assertErrorName   = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey
 
+-- Debug.Trace
+traceName          :: Name
+traceName         = varQual dEBUG_TRACE (fsLit "trace") traceKey
+
 -- Enum module (Enum, Bounded)
 enumClassName, enumFromName, enumFromToName, enumFromThenName,
     enumFromThenToName, boundedClassName :: Name
@@ -2185,6 +2190,9 @@ assertErrorIdKey              = mkPreludeMiscIdUnique 105
 oneShotKey                    = mkPreludeMiscIdUnique 106
 runRWKey                      = mkPreludeMiscIdUnique 107
 
+traceKey :: Unique
+traceKey                      = mkPreludeMiscIdUnique 108
+
 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey,
     breakpointJumpIdKey, breakpointCondJumpIdKey,
     breakpointAutoJumpIdKey :: Unique
diff --git a/libraries/base/Debug/Trace.hs-boot b/libraries/base/Debug/Trace.hs-boot
new file mode 100644
index 0000000..9dbbe2d
--- /dev/null
+++ b/libraries/base/Debug/Trace.hs-boot
@@ -0,0 +1,76 @@
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- This boot file is necessary to allow GHC developers to
+-- use trace facilities in those (relatively few) modules that Debug.Trace
+-- itself depends on. It is also necessary to make DsMonad.pprRuntimeTrace
+-- trace injections work in those modules.
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Debug.Trace
+-- Copyright   :  (c) The University of Glasgow 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer  :  libraries at haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Functions for tracing and monitoring execution.
+--
+-- These can be useful for investigating bugs or performance problems.
+-- They should /not/ be used in production code.
+--
+-----------------------------------------------------------------------------
+
+module Debug.Trace (
+        -- * Tracing
+        -- $tracing
+        trace,
+        traceId,
+        traceShow,
+        traceShowId,
+        traceStack,
+        traceIO,
+        traceM,
+        traceShowM,
+
+        -- * Eventlog tracing
+        -- $eventlog_tracing
+        traceEvent,
+        traceEventIO,
+
+        -- * Execution phase markers
+        -- $markers
+        traceMarker,
+        traceMarkerIO,
+  ) where
+
+import GHC.Base
+import GHC.Show
+
+traceIO :: String -> IO ()
+
+trace :: String -> a -> a
+
+traceId :: String -> String
+
+traceShow :: Show a => a -> b -> b
+
+traceShowId :: Show a => a -> a
+
+traceM :: Applicative f => String -> f ()
+
+traceShowM :: (Show a, Applicative f) => a -> f ()
+
+traceStack :: String -> a -> a
+
+traceEvent :: String -> a -> a
+
+traceEventIO :: String -> IO ()
+
+traceMarker :: String -> a -> a
+
+traceMarkerIO :: String -> IO ()