From 12efb230de40f24e4828734dd46627ebe24416b4 Mon Sep 17 00:00:00 2001
From: David Feuer <david.feuer@gmail.com>
Date: Fri, 1 Dec 2017 15:59:24 -0500
Subject: [PATCH] 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
---
compiler/deSugar/DsMonad.hs | 34 ++++++++++++-
compiler/prelude/PrelNames.hs | 12 ++++-
libraries/base/Debug/Trace.hs-boot | 76 ++++++++++++++++++++++++++++++
3 files changed, 119 insertions(+), 3 deletions(-)
create mode 100644 libraries/base/Debug/Trace.hs-boot
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 1eabf02161f2..ae39e3de5ab1 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 ae695d40e10d..f418348fcd6f 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 000000000000..9dbbe2dd3794
--- /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@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 ()
--
GitLab