Commit 12efb230 authored by David Feuer's avatar David Feuer Committed by David Feuer
Browse files

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
parent e1fb2838
......@@ -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]
......@@ -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
......
{-# 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 ()
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment