[Git][ghc/ghc][wip/T26331] 9 commits: Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
by Simon Peyton Jones (＠simonpj) 27 Aug '25
by Simon Peyton Jones (＠simonpj) 27 Aug '25
27 Aug '25
Simon Peyton Jones pushed to branch wip/T26331 at Glasgow Haskell Compiler / GHC
Commits:
5b5d9d47 by Ben Gamari at 2025-08-25T14:29:35-04:00
Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)"
This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd
- - - - -
10f06163 by Cheng Shao at 2025-08-25T14:30:16-04:00
wasm: ensure setKeepCAFs() is called in ghci
This patch is a critical bugfix for #26106, see comment and linked
issue for details.
- - - - -
bedc1004 by Cheng Shao at 2025-08-26T09:31:18-04:00
compiler: use zero cost coerce in hoopl setElems/mapToList
This patch is a follow-up of !14680 and changes setElems/mapToList in
GHC/Cmm/Dataflow/Label to use coerce instead of mapping mkHooplLabel
over the keys.
- - - - -
13250d97 by Ryan Scott at 2025-08-26T09:31:59-04:00
Reject infix promoted data constructors without DataKinds
In the rename, make sure to apply the same `DataKinds` checks for both
`HsTyVar` (for prefix promoted data constructors) and `HsOpTy` (for infix
promoted data constructors) alike.
Fixes #26318.
- - - - -
37655c46 by Teo Camarasu at 2025-08-26T15:24:51-04:00
tests: disable T22859 under LLVM
This test was failing under the LLVM backend since the allocations
differ from the NCG.
Resolves #26282
- - - - -
2cbba9d6 by Teo Camarasu at 2025-08-26T15:25:33-04:00
base-exports: update version numbers
As the version of the compiler has been bumped, a lot of the embedded
version numbers will need to be updated if we ever run this test with
`--test-accept` so let's just update them now, and keep future diffs
clean.
- - - - -
f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
be2fdbbf by Simon Peyton Jones at 2025-08-27T16:39:49+01:00
Fix deep subsumption again
This commit fixed #26255:
commit 56b32c5a2d5d7cad89a12f4d74dc940e086069d1
Author: sheaf <sam.derbyshire(a)gmail.com>
Date: Mon Aug 11 15:50:47 2025 +0200
Improve deep subsumption
This commit improves the DeepSubsumption sub-typing implementation
in GHC.Tc.Utils.Unify.tc_sub_type_deep by being less eager to fall back
to unification.
But alas it still wasn't quite right for view patterns: #26133.
This MR does a generalisation to fix it. A bit of a sledgehammer to crack
a nut, but nice.
* Add a field `ir_inst :: InferInstFlag` to `InferResult`, where
```
data InferInstFlag = IIF_Sigma | IIF_ShallowRho | IIF_DeepRho
```
* The flag says exactly how much `fillInferResult` should instantiate
before filling the hole.
* We can also use this to replace the previous very ad-hoc `tcInferSigma`
that was used to implement GHCi's `:type` command.
- - - - -
53 changed files:
- compiler/GHC/Cmm/Dataflow/Label.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Expr.hs-boot
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- rts/PrimOps.cmm
- rts/RaiseAsync.c
- rts/STM.c
- testsuite/.gitignore
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- − testsuite/tests/lib/stm/T26028.hs
- − testsuite/tests/lib/stm/T26028.stdout
- − testsuite/tests/lib/stm/all.T
- testsuite/tests/rts/all.T
- testsuite/tests/th/Makefile
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/all.T
- + testsuite/tests/typecheck/should_fail/T26318.hs
- + testsuite/tests/typecheck/should_fail/T26318.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/jsffi/dyld.mjs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6c8f7710198b27c13044291a29f30…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a6c8f7710198b27c13044291a29f30…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/stack-annotation-with-backtraces] Expose Stack Annotation frames in IPE backtraces by default
by Hannes Siebenhandl (＠fendor) 27 Aug '25
by Hannes Siebenhandl (＠fendor) 27 Aug '25
27 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC
Commits:
36314d04 by fendor at 2025-08-27T17:09:14+02:00
Expose Stack Annotation frames in IPE backtraces by default
When decoding the Haskell-native call stack and displaying the IPE information
for the stack frames, we print the `StackAnnotation` of the `AnnFrame` by default.
This means, when an exception is thrown, any intermediate stack annotations will
be displayed in the `IPE Backtrace`.
Example backtrace:
```
Exception: ghc-internal:GHC.Internal.Exception.ErrorCall:
Oh no!
IPE backtrace:
annotateCallStackIO, called at app/Main.hs:48:10 in backtrace-0.1.0.0-inplace-server:Main
annotateCallStackIO, called at app/Main.hs:46:13 in backtrace-0.1.0.0-inplace-server:Main
Main.handler (app/Main.hs:(46,1)-(49,30))
Main.liftIO (src/Servant/Server/Internal/Handler.hs:30:36-42)
Servant.Server.Internal.Delayed.runHandler' (src/Servant/Server/Internal/Handler.hs:27:31-41)
Control.Monad.Trans.Resource.runResourceT (./Control/Monad/Trans/Resource.hs:(192,14)-(197,18))
Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:195:20-22)
Network.Wai.Handler.Warp.HTTP1.processRequest (./Network/Wai/Handler/Warp/HTTP1.hs:(195,5)-(203,31))
Network.Wai.Handler.Warp.HTTP1.http1server.loop (./Network/Wai/Handler/Warp/HTTP1.hs:(141,9)-(157,42))
HasCallStack backtrace:
error, called at app/Main.hs:48:32 in backtrace-0.1.0.0-inplace-server:Main
```
The first two entries have been added by `annotateCallStackIO`, defined in `annotateCallStackIO`.
- - - - -
9 changed files:
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
=====================================
@@ -58,6 +58,7 @@ import Data.Typeable
import GHC.Exts
import GHC.IO
import GHC.Internal.Stack
+import GHC.Internal.Stack.Annotation
-- Note [User-defined stack annotations for better stack traces]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -127,31 +128,10 @@ import GHC.Internal.Stack
-- This means, right now, if you want to reliably capture stack frame annotations,
-- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'.
--- ----------------------------------------------------------------------------
--- StackAnnotation
--- ----------------------------------------------------------------------------
-
--- | 'StackAnnotation's are types which can be pushed onto the call stack
--- as the payload of 'AnnFrame' stack frames.
---
-class StackAnnotation a where
- displayStackAnnotation :: a -> String
-
-- ----------------------------------------------------------------------------
-- Annotations
-- ----------------------------------------------------------------------------
--- |
--- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
--- When the call stack is annotated with a value of type @a@, behind the scenes it is
--- encapsulated in a @SomeStackAnnotation@.
---
-data SomeStackAnnotation where
- SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
-
-instance StackAnnotation SomeStackAnnotation where
- displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
-
data StringAnnotation where
StringAnnotation :: String -> StringAnnotation
@@ -175,7 +155,7 @@ instance Show CallStackAnnotation where
instance StackAnnotation CallStackAnnotation where
displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of
[] -> "<unknown source location>"
- ((_,srcLoc):_) -> prettySrcLoc srcLoc
+ ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc
-- ----------------------------------------------------------------------------
-- Annotate the CallStack with custom data
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -295,6 +295,7 @@ Library
GHC.Internal.Stable
GHC.Internal.StableName
GHC.Internal.Stack
+ GHC.Internal.Stack.Annotation
GHC.Internal.Stack.CCS
GHC.Internal.Stack.CloneStack
GHC.Internal.Stack.Constants
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -11,7 +11,7 @@ import GHC.Internal.IORef
import GHC.Internal.IO.Unsafe (unsafePerformIO)
import GHC.Internal.Exception.Context
import GHC.Internal.Ptr
-import GHC.Internal.Data.Maybe (fromMaybe)
+import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
@@ -144,7 +144,7 @@ displayBacktraces bts = concat
displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
-- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
-- references closures can be garbage collected.
- displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
+ displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe
displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module GHC.Internal.Stack.Annotation where
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Typeable
+
+-- ----------------------------------------------------------------------------
+-- StackAnnotation
+-- ----------------------------------------------------------------------------
+
+-- | 'StackAnnotation's are types which can be pushed onto the call stack
+-- as the payload of 'AnnFrame' stack frames.
+--
+class StackAnnotation a where
+ displayStackAnnotation :: a -> String
+
+-- ----------------------------------------------------------------------------
+-- Annotations
+-- ----------------------------------------------------------------------------
+
+-- |
+-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
+-- When the call stack is annotated with a value of type @a@, behind the scenes it is
+-- encapsulated in a @SomeStackAnnotation@.
+--
+data SomeStackAnnotation where
+ SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
+
+instance StackAnnotation SomeStackAnnotation where
+ displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -23,6 +24,7 @@ module GHC.Internal.Stack.Decode (
StackEntry(..),
-- * Pretty printing
prettyStackEntry,
+ prettyStackFrameWithIpe,
)
where
@@ -39,6 +41,7 @@ import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
import GHC.Internal.Exts
+import GHC.Internal.Unsafe.Coerce
import GHC.Internal.ClosureTypes
import GHC.Internal.Heap.Closures
@@ -52,6 +55,7 @@ import GHC.Internal.Heap.Closures
)
import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Stack.Annotation
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.CloneStack
import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
@@ -560,6 +564,16 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
-- Pretty printing functions for stack entires, stack frames and provenance info
-- ----------------------------------------------------------------------------
+prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
+prettyStackFrameWithIpe (frame, mipe) =
+ case frame of
+ AnnFrame {annotation = Box someStackAnno } ->
+ case unsafeCoerce someStackAnno of
+ SomeStackAnnotation ann ->
+ Just $ displayStackAnnotation ann
+ _ ->
+ (prettyStackEntry . toStackEntry) <$> mipe
+
prettyStackEntry :: StackEntry -> String
prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
=====================================
@@ -1,11 +1,11 @@
Start some work
10946
Stack annotations:
-- ann_frame002.hs:18:7 in main:Main
-- ann_frame002.hs:12:11 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:18:7 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:12:11 in main:Main
Finish some work
Some more work in bar
17711
Stack annotations:
- bar
-- ann_frame002.hs:23:7 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main
=====================================
libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
=====================================
@@ -1,17 +1,17 @@
Stack annotations:
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:13:10 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:13:10 in main:Main
- bar
-- ann_frame004.hs:12:7 in main:Main
+- annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -10949,10 +10949,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11151,3 +11147,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -10952,10 +10952,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11154,3 +11150,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36314d049da3f39f0196877be1c20f5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/36314d049da3f39f0196877be1c20f5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/9.12.3-backports] llvmGen: Fix built-in variable predicate
by Zubin (＠wz1000) 27 Aug '25
by Zubin (＠wz1000) 27 Aug '25
27 Aug '25
Zubin pushed to branch wip/9.12.3-backports at Glasgow Haskell Compiler / GHC
Commits:
e67ba5ed by Ben Gamari at 2025-08-27T18:49:38+05:30
llvmGen: Fix built-in variable predicate
Previously the predicate to identify LLVM builtin global variables was
checking for `$llvm` rather than `@llvm` as it should.
(cherry picked from commit 6e67fa083a50684e1cfae546e07cab4d4250e871)
- - - - -
1 changed file:
- compiler/GHC/CmmToLlvm/Base.hs
Changes:
=====================================
compiler/GHC/CmmToLlvm/Base.hs
=====================================
@@ -526,10 +526,10 @@ generateExternDecls = do
modifyEnv $ \env -> env { envAliases = emptyUniqSet }
return (concat defss, [])
--- | Is a variable one of the special @$llvm@ globals?
+-- | Is a variable one of the special @\@llvm@ globals?
isBuiltinLlvmVar :: LlvmVar -> Bool
isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
- "$llvm" `isPrefixOf` unpackFS lbl
+ "llvm." `isPrefixOf` unpackFS lbl
isBuiltinLlvmVar _ = False
-- | Here we take a global variable definition, rename it with a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e67ba5ed9c896235e9c50a20b5062fc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e67ba5ed9c896235e9c50a20b5062fc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T26346 at Glasgow Haskell Compiler / GHC
Commits:
b9d19411 by Simon Peyton Jones at 2025-08-27T12:35:53+01:00
Responding to Sam
- - - - -
3 changed files:
- compiler/GHC/Core/Unify.hs
- + testsuite/tests/typecheck/should_compile/T26358.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -431,24 +431,7 @@ Wrinkles
(ATF12) There is a horrid exception for the injectivity check. See (UR1) in
in Note [Specification of unification].
-(ATF13) Consider unifying
- [F a, F Int, Int] ~ [Bool, Char, a]
- Working left to right you might think we would build the mapping
- F a :-> Bool
- F Int :-> Char
- Now we discover that `a` unifies with `Int`. So really these two lists are Apart
- because F Int can't be both Bool and Char.
-
- But that is very tricky! Perhaps whenever we unify a type variable we should
- run it over the domain and (maybe range) of the type-family mapping too?
- Sigh.
-
- For we make no such attempt. The um_fam_env has only pre-substituted types.
- Fortunately, while this may make use say MaybeApart when we could say SurelyApart,
- it has no effect on the correctness of unification: if we return Unifiable, it
- really is Unifiable.
-
-(ATF14) We have to be careful about the occurs check.
+(ATF13) We have to be careful about the occurs check.
See Note [The occurs check in the Core unifier]
SIDE NOTE. The paper "Closed type families with overlapping equations"
@@ -474,6 +457,49 @@ and all is lost. But with the current algorithm we have that
a a ~ (Var A) (Var B)
is SurelyApart, so the first equation definitely doesn't match and we can try the
second, which does. END OF SIDE NOTE.
+
+Note [Shortcomings of the apartness test]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Apartness and type families] is very clever.
+
+But it still has shortcomings (#26358). Consider unifying
+ [F a, F Int, Int] ~ [Bool, Char, a]
+Working left to right you might think we would build the mapping
+ F a :-> Bool
+ F Int :-> Char
+Now we discover that `a` unifies with `Int`. So really these two lists are Apart
+because F Int can't be both Bool and Char.
+
+Just the same applies when adding a type-family binding to um_fam_env:
+ [F (G Float), F Int, G Float] ~ [Bool, Char, Iont]
+Again these are Apart, because (G Float = Int),
+and (F Int) can't be both Bool and Char
+
+But achieving this is very tricky! Perhaps whenever we unify a type variable,
+or a type family, we should run it over the domain and (maybe range) of the
+type-family mapping too? Sigh.
+
+For now we make no such attempt.
+* The um_fam_env has only /un-substituted/ types.
+* We look up on ly /un-substituted/ types in um_fam_env
+
+This may make us say MaybeApart when we could say SurelyApart, but it has no
+effect on the correctness of unification: if we return Unifiable, it really is
+Unifiable.
+
+This is all quite subtle. suppose we have:
+ um_tv_env: c :-> b
+ um_fam_env F b :-> a
+and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will
+fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq,
+getting:
+ um_tv_env: a :-> F c, c :-> b
+ um_fam_env F b :-> a
+
+Does that loop, like this:
+ a --> F c --> F b --> a?
+No, becuase we do not substitute (F c) to (F b) and then look up in um_fam_env;
+we look up only un-substituted types.
-}
{- *********************************************************************
@@ -1810,6 +1836,7 @@ uVarOrFam env ty1 ty2 kco
-----------------------------
-- LHS is a type variable
-- The sequence of tests is very similar to go_tv
+ go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM ()
go swapped substs lhs@(TyVarLHS tv1) ty2 kco
| Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'
= -- We already have a substitution for tv1
@@ -1863,7 +1890,7 @@ uVarOrFam env ty1 ty2 kco
tv1' = umRnOccL env tv1
ty2_fvs = tyCoVarsOfType ty2
rhs = ty2 `mkCastTy` mkSymCo kco
- tv1_is_bindable | not (tv1' `elemVarSet` um_foralls env)
+ tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs)
-- tv1' is not forall-bound, but tv1 can still differ
-- from tv1; see Note [Cloning the template binders]
-- in GHC.Core.Rules. So give tv1' to um_bind_tv_fun.
@@ -1872,7 +1899,8 @@ uVarOrFam env ty1 ty2 kco
| otherwise
= False
- occurs_check = um_unif env && uOccursCheck substs lhs rhs
+ foralld_tvs = um_foralls env
+ occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs
-- Occurs check, only when unifying
-- see Note [Infinitary substitutions]
-- Make sure you include `kco` in rhs #14846
@@ -1906,9 +1934,11 @@ uVarOrFam env ty1 ty2 kco
-- Now check if we can bind the (F tys) to the RHS
-- This can happen even when matching: see (ATF7)
| BindMe <- um_bind_fam_fun env tc1 tys1 rhs
- = if uOccursCheck substs lhs rhs
+ = if uOccursCheck substs emptyVarSet lhs rhs
then maybeApart MARInfinite
- else do { extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13)
+ else do { extendFamEnv tc1 tys1 rhs
+ -- We don't substitute tys1 before extending
+ -- See Note [Shortcomings of the apartness test]
; maybeApart MARTypeFamily }
-- Swap in case of (F a b) ~ (G c d e)
@@ -1929,6 +1959,7 @@ uVarOrFam env ty1 ty2 kco
-----------------------------
-- go_fam_fam: LHS and RHS are both saturated type-family applications,
-- for the same type-family F
+ -- Precondition: um_foralls is empty
go_fam_fam substs tc tys1 tys2 kco
-- Decompose (F tys1 ~ F tys2): (ATF9)
-- Use injectivity information of F: (ATF10)
@@ -1950,11 +1981,11 @@ uVarOrFam env ty1 ty2 kco
| not (um_unif env) -- Not when matching (ATF11-1)
= return ()
| BindMe <- um_bind_fam_fun env tc tys1 rhs1
- = unless (uOccursCheck substs (TyFamLHS tc tys1) rhs1) $
+ = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $
extendFamEnv tc tys1 rhs1
-- At this point um_unif=True, so we can unify either way
| BindMe <- um_bind_fam_fun env tc tys2 rhs2
- = unless (uOccursCheck substs (TyFamLHS tc tys2) rhs2) $
+ = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $
extendFamEnv tc tys2 rhs2
| otherwise
= return ()
@@ -1963,12 +1994,15 @@ uVarOrFam env ty1 ty2 kco
rhs2 = mkTyConApp tc tys1 `mkCastTy` kco
-uOccursCheck :: UMState -> CanEqLHS -> Type -> Bool
--- See Note [The occurs check in the Core unifier] and (ATF14)
-uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty
- = go emptyVarSet ty
+uOccursCheck :: UMState
+ -> TyVarSet -- Bound by enclosing foralls; see (OCU1)
+ -> CanEqLHS -> Type -- Can we unify (lhs := ty)?
+ -> Bool
+-- See Note [The occurs check in the Core unifier] and (ATF13)
+uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty
+ = go bvs ty
where
- go :: TyCoVarSet -- Bound by enclosing foralls
+ go :: TyCoVarSet -- Bound by enclosing foralls; see (OCU1)
-> Type -> Bool
go bvs ty | Just ty' <- coreView ty = go bvs ty'
go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv
@@ -1993,8 +2027,11 @@ uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty
go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`?
go_tc bvs tc tys
- | isTypeFamilyTyCon tc
+ | isEmptyVarSet bvs -- Never look up in um_fam_env under a forall (ATF3)
+ , isTypeFamilyTyCon tc
, Just ty' <- lookupFamEnv fam_env tc (take arity tys)
+ -- NB: we look up /un-substituted/ types;
+ -- See Note [Shortcomings of the apartness test]
= go bvs ty' || any (go bvs) (drop arity tys)
| TyFamLHS tc' tys' <- lhs
@@ -2022,6 +2059,11 @@ could lead to a loop. That is, could there by a type `s` such that
It's vital that we do both at once: we might have (1) already and add (2);
or we might have (2) already and add (1).
+(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive
+ under a forall; indeed it is /unsound/ to consult it becuase we have have a binding
+ (F a :-> Int), and then unify (forall a. ...(F a)...) with something. We don't
+ want to map that (F a) to Int!
+
Note [Unifying coercion-foralls]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we try to unify (forall cv. t1) ~ (forall cv. t2).
=====================================
testsuite/tests/typecheck/should_compile/T26358.hs
=====================================
@@ -0,0 +1,48 @@
+{-# LANGUAGE TypeFamilies #-}
+
+module T26358 where
+import Data.Kind
+import Data.Proxy
+
+{- Two failing tests, described in GHC.Core.Unify
+ Note [Shortcomings of the apartness test]
+
+Explanation for TF2
+* We try to reduce
+ (TF2 (F (G Float)) (F Int) (G Float))
+* We can only do so if those arguments are apart from the first
+ equation of TF2, namely (Bool,Char,Int).
+* So we try to unify
+ [F (G Float), F Int, G Float] ~ [Bool, Char, Int]
+* They really are apart, but we can't quite spot that yet;
+ hence #26358
+
+TF1 is similar.
+-}
+
+
+type TF1 :: Type -> Type -> Type -> Type
+type family TF1 a b c where
+ TF1 Bool Char a = Word
+ TF1 a b c = (a,b,c)
+
+type F :: Type -> Type
+type family F a where
+
+foo :: Proxy a
+ -> Proxy (TF1 (F a) (F Int) Int)
+ -> Proxy (F a, F Int, Int)
+foo _ px = px
+
+type TF2 :: Type -> Type -> Type -> Type
+type family TF2 a b c where
+ TF2 Bool Char Int = Word
+ TF2 a b c = (a,b,c)
+
+type G :: Type -> Type
+type family G a where
+
+bar :: Proxy (TF2 (F (G Float)) (F Int) (G Float))
+ -> Proxy (F (G Float), F Int, G Float)
+bar px = px
+
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -946,3 +946,4 @@ test('T14010', normal, compile, [''])
test('T26256a', normal, compile, [''])
test('T25992a', normal, compile, [''])
test('T26346', normal, compile, [''])
+test('T26358', expect_broken(26358), compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d194118242f03283813c7b8234399…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d194118242f03283813c7b8234399…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
by Marge Bot (＠marge-bot) 27 Aug '25
by Marge Bot (＠marge-bot) 27 Aug '25
27 Aug '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
ae89f000 by Hassan Al-Awwadi at 2025-08-27T07:19:56-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
23 changed files:
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/.gitignore
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/th/Makefile
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -75,14 +75,15 @@ data UsageConfig = UsageConfig
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv
-> Module -> ImportedMods -> [ImportUserSpec] -> NameSet
- -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
+ -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
-> IfG [Usage]
mkUsageInfo uc plugins fc unit_env
this_mod dir_imp_mods imp_decls used_names
- dependent_files merged needed_links needed_pkgs
+ dependent_files dependent_dirs merged needed_links needed_pkgs
= do
eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))
- hashes <- liftIO $ mapM getFileHash dependent_files
+ file_hashes <- liftIO $ mapM getFileHash dependent_files
+ dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
let hu = ue_unsafeHomeUnit unit_env
hug = ue_home_unit_graph unit_env
-- Dependencies on object files due to TH and plugins
@@ -93,7 +94,11 @@ mkUsageInfo uc plugins fc unit_env
let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f
, usg_file_hash = hash
, usg_file_label = Nothing }
- | (f, hash) <- zip dependent_files hashes ]
+ | (f, hash) <- zip dependent_files file_hashes ]
+ ++ [ UsageDirectory { usg_dir_path = mkFastString d
+ , usg_dir_hash = hash
+ , usg_dir_label = Nothing }
+ | (d, hash) <- zip dependent_dirs dirs_hashes]
++ [ UsageMergedRequirement
{ usg_mod = mod,
usg_mod_hash = hash
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -269,6 +269,7 @@ mkRecompUsageInfo hsc_env tc_result = do
else do
let used_names = mkUsedNames tc_result
dep_files <- (readIORef (tcg_dependent_files tc_result))
+ dep_dirs <- (readIORef (tcg_dependent_dirs tc_result))
(needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)
let uc = initUsageConfig hsc_env
plugins = hsc_plugins hsc_env
@@ -289,6 +290,7 @@ mkRecompUsageInfo hsc_env tc_result = do
(tcg_import_decls tc_result)
used_names
dep_files
+ dep_dirs
(tcg_merged tc_result)
needed_links
needed_pkgs
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -194,6 +194,7 @@ data RecompReason
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
+ | DirChanged FilePath
| CustomReason String
| FlagsChanged
| LinkFlagsChanged
@@ -230,6 +231,7 @@ instance Outputable RecompReason where
ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
+ DirChanged dp -> text "Contents of" <+> text dp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
LinkFlagsChanged -> text "Flags changed"
@@ -815,6 +817,22 @@ checkModUsage fc UsageFile{ usg_file_path = file,
then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
else \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+checkModUsage fc UsageDirectory{ usg_dir_path = dir,
+ usg_dir_hash = old_hash,
+ usg_dir_label = mlabel } =
+ liftIO $
+ handleIO handler $ do
+ new_hash <- lookupDirCache fc $ unpackFS dir
+ if (old_hash /= new_hash)
+ then return recomp
+ else return UpToDate
+ where
+ reason = DirChanged $ unpackFS dir
+ recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
+ handler = if debugIsOn
+ then \e -> pprTrace "UsageDirectory" (text (show e)) $ return recomp
+ else \_ -> return recomp -- if we can't find the dir, just recompile, don't fail
+
-- | We are importing a module whose exports have changed.
-- Does this require recompilation?
--
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -140,6 +140,10 @@ pprUsage usage@UsageFile{}
= hsep [text "addDependentFile",
doubleQuotes (ftext (usg_file_path usage)),
ppr (usg_file_hash usage)]
+pprUsage usage@UsageDirectory{}
+ = hsep [text "AddDependentDirectory",
+ doubleQuotes (ftext (usg_dir_path usage)),
+ ppr (usg_dir_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
pprUsage usage@UsageHomeModuleInterface{}
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -173,8 +173,6 @@ import GHC.Parser.HaddockLex (lexHsDoc)
import GHC.Parser (parseIdentifier)
import GHC.Rename.Doc (rnHsDoc)
-
-
{-
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1524,6 +1522,11 @@ instance TH.Quasi TcM where
dep_files <- readTcRef ref
writeTcRef ref (fp:dep_files)
+ qAddDependentDirectory dp = do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
qAddTempFile suffix = do
dflags <- getDynFlags
logger <- getLogger
@@ -1928,6 +1931,7 @@ handleTHMessage msg = case msg of
ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -603,6 +603,7 @@ data TcGblEnv
-- decls.
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
+ tcg_dependent_dirs :: TcRef [FilePath], -- ^ dependencies from addDependentDirectory
tcg_th_topdecls :: TcRef [LHsDecl GhcPs],
-- ^ Top-level declarations from addTopDecls
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad(
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv,
getDeclaredDefaultTys,
- addDependentFiles,
+ addDependentFiles, addDependentDirectories,
-- * Error management
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
@@ -273,6 +273,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
let { type_env_var = hsc_type_env_vars hsc_env };
dependent_files_var <- newIORef [] ;
+ dependent_dirs_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
cc_st_var <- newIORef newCostCentreState ;
th_topdecls_var <- newIORef [] ;
@@ -368,6 +369,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_safe_infer = infer_var,
tcg_safe_infer_reasons = infer_reasons_var,
tcg_dependent_files = dependent_files_var,
+ tcg_dependent_dirs = dependent_dirs_var,
tcg_tc_plugin_solvers = [],
tcg_tc_plugin_rewriters = emptyUFM,
tcg_defaulting_plugins = [],
@@ -956,6 +958,12 @@ addDependentFiles fs = do
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
+addDependentDirectories :: [FilePath] -> TcRn ()
+addDependentDirectories ds = do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (ds ++ dep_dirs)
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -31,6 +31,9 @@ module GHC.Unit.Finder (
findObjectLinkableMaybe,
findObjectLinkable,
+
+ -- important that GHC.HsToCore.Usage uses the same hashing method for usage dirs as is used here.
+ getDirHash,
) where
import GHC.Prelude
@@ -69,7 +72,9 @@ import GHC.Types.Unique.Map
import GHC.Driver.Env
import GHC.Driver.Config.Finder
import GHC.Types.Unique.Set
+import qualified Data.List as L(sort)
import Data.List.NonEmpty ( NonEmpty (..) )
+import qualified System.Directory as SD
import qualified System.OsPath as OsPath
import qualified Data.List.NonEmpty as NE
@@ -108,10 +113,12 @@ initFinderCache :: IO FinderCache
initFinderCache = do
mod_cache <- newIORef emptyInstalledModuleEnv
file_cache <- newIORef M.empty
+ dir_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
+ atomicModifyIORef' dir_cache $ \_ -> (M.empty, ())
where
is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
@@ -138,8 +145,27 @@ initFinderCache = do
atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ())
return hash
Just fp -> return fp
+ lookupDirCache :: FilePath -> IO Fingerprint
+ lookupDirCache key = do
+ c <- readIORef dir_cache
+ case M.lookup key c of
+ Nothing -> do
+ hash <- getDirHash key
+ atomicModifyIORef' dir_cache $ \c -> (M.insert key hash c, ())
+ return hash
+ Just fp -> return fp
return FinderCache{..}
+-- | This function computes a shallow hash of a directory, so really just what files and directories are directly inside it.
+-- It does not look at the contents of the files, or the contents of the directories it contains.
+getDirHash :: FilePath -> IO Fingerprint
+getDirHash dir = do
+ contents <- SD.listDirectory dir
+ let hashes = fingerprintString <$> contents
+ let s_hashes = L.sort hashes
+ let hash = fingerprintFingerprints s_hashes
+ return hash
+
-- -----------------------------------------------------------------------------
-- The three external entry points
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -38,6 +38,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
, lookupFileCache :: FilePath -> IO Fingerprint
-- ^ Look for the hash of a file in the cache. This should add it to the
-- cache. If the file doesn't exist, raise an IOException.
+ , lookupDirCache :: FilePath -> IO Fingerprint
}
data InstalledFindResult
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -357,6 +357,23 @@ data Usage
-- contents don't change. This previously lead to odd
-- recompilation behaviors; see #8114
}
+ | UsageDirectory {
+ usg_dir_path :: FastString,
+ -- ^ External dir dependency. From TH addDependentFile.
+ -- Should be absolute.
+ usg_dir_hash :: Fingerprint,
+ -- ^ 'Fingerprint' of the directories contents.
+
+ usg_dir_label :: Maybe String
+ -- ^ An optional string which is used in recompilation messages if
+ -- dir in question has changed.
+
+ -- Note: We do a very shallow check indeed, just what the contents of
+ -- the directory are, aka what files and directories are within it.
+ -- If those files/directories have their own contents changed, then
+ -- we won't spot it here. If you do want to spot that, the caller
+ -- should recursively add them to their useage.
+ }
| UsageHomeModuleInterface {
usg_mod_name :: ModuleName
-- ^ Name of the module
@@ -395,6 +412,7 @@ instance NFData Usage where
rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` ()
rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` ()
rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
+ rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
@@ -431,6 +449,12 @@ instance Binary Usage where
put_ bh (usg_unit_id usg)
put_ bh (usg_iface_hash usg)
+ put_ bh usg@UsageDirectory{} = do
+ putByte bh 5
+ put_ bh (usg_dir_path usg)
+ put_ bh (usg_dir_hash usg)
+ put_ bh (usg_dir_label usg)
+
get bh = do
h <- getByte bh
case h of
@@ -462,6 +486,12 @@ instance Binary Usage where
uid <- get bh
hash <- get bh
return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
+ 5 -> do
+ dp <- get bh
+ hash <- get bh
+ label <- get bh
+ return UsageDirectory { usg_dir_path = dp, usg_dir_hash = hash, usg_dir_label = label }
+
i -> error ("Binary.get(Usage): " ++ show i)
-- | Records the imports that we depend on from a home module,
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -55,6 +55,11 @@ Cmm
``template-haskell`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- We have added the ``addDependentDirectory`` function to match
+ ``addDependentFile``, which adds a directory to the list of dependencies that
+ the recompilation checker will look at to determine if a module needs to be
+ recompiled.
+
Included libraries
~~~~~~~~~~~~~~~~~~
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -710,7 +710,7 @@ beautiful sight!
You can read about :ghc-wiki:`how all this works <commentary/compiler/recompilation-avoidance>` in the GHC commentary.
Recompilation for Template Haskell and Plugins
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recompilation checking gets a bit more complicated when using Template Haskell or
plugins. Both these features execute code at compile time and so if any of the
@@ -727,6 +727,19 @@ if ``foo`` is from module ``A`` and ``bar`` is from module ``B``, the module wil
now depend on ``A.o`` and ``B.o``, if either of these change then the module will
be recompiled.
+``addDependentFile`` and ``addDependentDirectory``
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+When using Template Haskell or plugins, you can use the functions
+``addDependentFile`` and ``addDependentDirectory`` to add additional
+dependencies to the module being compiled.
+
+- When adding a file, this means that the contents of the file changing between
+ compilations will trigger a recompilation of the module.
+- When adding a directory, this means that any file or subdirectory *added* to or
+ *removed* from the directory will trigger recompilation of the module, so
+ it is not a recursive dependency.
+
.. _mutual-recursion:
Mutually recursive modules and hs-boot files
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -132,6 +132,9 @@ class (MonadIO m, MonadFail m) => Quasi m where
-- | See 'addDependentFile'.
qAddDependentFile :: FilePath -> m ()
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+
-- | See 'addTempFile'.
qAddTempFile :: String -> m FilePath
@@ -202,6 +205,7 @@ instance Quasi IO where
qExtsEnabled = badIO "extsEnabled"
qPutDoc _ _ = badIO "putDoc"
qGetDoc _ = badIO "getDoc"
+ qAddDependentDirectory _ = badIO "AddDependentDirectory"
instance Quote IO where
newName = newNameIO
@@ -819,6 +823,24 @@ getPackageRoot :: Q FilePath
getPackageRoot = Q qGetPackageRoot
+-- | Record external directories that runIO is using (dependent upon).
+-- The compiler can then recognize that it should re-compile the Haskell file
+-- when a directory changes.
+--
+-- Notes:
+--
+-- * ghc -M does not know about these dependencies - it does not execute TH.
+--
+-- * The dependency is shallow, based only on the direct content.
+-- Basically, it only sees a list of names. It does not look at directory
+-- metadata, recurse into subdirectories, or look at file contents. As
+-- long as the list of names remains the same, the directory is considered
+-- unchanged.
+--
+-- * The state of the directory is read at the interface generation time,
+-- not at the time of the function call.
+addDependentDirectory :: FilePath -> Q ()
+addDependentDirectory dp = Q (qAddDependentDirectory dp)
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +852,11 @@ getPackageRoot = Q qGetPackageRoot
--
-- * ghc -M does not know about these dependencies - it does not execute TH.
--
--- * The dependency is based on file content, not a modification time
+-- * The dependency is based on file content, not a modification time or
+-- any other metadata associated with the file (e.g. permissions).
+--
+-- * The state of the file is read at the interface generation time,
+-- not at the time of the function call.
addDependentFile :: FilePath -> Q ()
addDependentFile fp = Q (qAddDependentFile fp)
@@ -952,32 +978,33 @@ instance MonadIO Q where
liftIO = runIO
instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyFixity = reifyFixity
+ qReifyType = reifyType
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qReifyConStrictness = reifyConStrictness
+ qLookupName = lookupName
+ qLocation = location
+ qGetPackageRoot = getPackageRoot
+ qAddDependentFile = addDependentFile
+ qAddDependentDirectory = addDependentDirectory
+ qAddTempFile = addTempFile
+ qAddTopDecls = addTopDecls
+ qAddForeignFilePath = addForeignFilePath
+ qAddModFinalizer = addModFinalizer
+ qAddCorePlugin = addCorePlugin
+ qGetQ = getQ
+ qPutQ = putQ
+ qIsExtEnabled = isExtEnabled
+ qExtsEnabled = extsEnabled
+ qPutDoc = putDoc
+ qGetDoc = getDoc
----------------------------------------------------
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -291,6 +291,7 @@ data THMessage a where
GetPackageRoot :: THMessage (THResult FilePath)
AddDependentFile :: FilePath -> THMessage (THResult ())
+ AddDependentDirectory :: FilePath -> THMessage (THResult ())
AddTempFile :: String -> THMessage (THResult FilePath)
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddCorePlugin :: String -> THMessage (THResult ())
@@ -343,6 +344,7 @@ getTHMessage = do
23 -> THMsg <$> (PutDoc <$> get <*> get)
24 -> THMsg <$> GetDoc <$> get
25 -> THMsg <$> return GetPackageRoot
+ 26 -> THMsg <$> AddDependentDirectory <$> get
n -> error ("getTHMessage: unknown message " ++ show n)
putTHMessage :: THMessage a -> Put
@@ -373,7 +375,7 @@ putTHMessage m = case m of
PutDoc l s -> putWord8 23 >> put l >> put s
GetDoc l -> putWord8 24 >> put l
GetPackageRoot -> putWord8 25
-
+ AddDependentDirectory a -> putWord8 26 >> put a
data EvalOpts = EvalOpts
{ useSandboxThread :: Bool
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -195,6 +195,7 @@ instance TH.Quasi GHCiQ where
qLocation = fromMaybe noLoc . qsLocation <$> getState
qGetPackageRoot = ghcCmd GetPackageRoot
qAddDependentFile file = ghcCmd (AddDependentFile file)
+ qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
qAddTempFile suffix = ghcCmd (AddTempFile suffix)
qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -34,6 +34,7 @@ module Language.Haskell.TH.Syntax (
ModName (..),
addCorePlugin,
addDependentFile,
+ addDependentDirectory,
addForeignFile,
addForeignFilePath,
addForeignSource,
=====================================
testsuite/.gitignore
=====================================
@@ -1523,6 +1523,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
/tests/th/T8633
/tests/th/TH_Depends
/tests/th/TH_Depends_external.txt
+/tests/th/TH_Depends_external/dummy.txt
/tests/th/TH_StringPrimL
/tests/th/TH_import_loop/ModuleA.hi-boot
/tests/th/TH_import_loop/ModuleA.o-boot
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1717,6 +1717,7 @@ module Language.Haskell.TH.Syntax where
qRunIO :: forall a. GHC.Internal.Types.IO a -> m a
qGetPackageRoot :: m GHC.Internal.IO.FilePath
qAddDependentFile :: GHC.Internal.IO.FilePath -> m ()
+ qAddDependentDirectory :: GHC.Internal.IO.FilePath -> m ()
qAddTempFile :: GHC.Internal.Base.String -> m GHC.Internal.IO.FilePath
qAddTopDecls :: [Dec] -> m ()
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
@@ -1728,7 +1729,7 @@ module Language.Haskell.TH.Syntax where
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1781,6 +1782,7 @@ module Language.Haskell.TH.Syntax where
type VarStrictType :: *
type VarStrictType = VarBangType
addCorePlugin :: GHC.Internal.Base.String -> Q ()
+ addDependentDirectory :: GHC.Internal.IO.FilePath -> Q ()
addDependentFile :: GHC.Internal.IO.FilePath -> Q ()
addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q ()
addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q ()
=====================================
testsuite/tests/th/Makefile
=====================================
@@ -43,6 +43,46 @@ TH_Depends:
'$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends
./TH_Depends
+.PHONY: TH_Depends_Dir
+TH_Depends_Dir:
+ rm -rf TRIGGER_RECOMP
+ rm -rf DONT_TRIGGER_RECOMP
+ $(RM) TH_Depends_Dir TH_Depends_Dir.exe
+ $(RM) TH_Depends_Dir.o TH_Depends_Dir.hi
+ $(RM) TH_Depends_Dir_External.o TH_Depends_Dir_External.hi
+
+ mkdir TRIGGER_RECOMP
+ mkdir DONT_TRIGGER_RECOMP
+
+# First build with an empty dependent directory
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Create a file in the dependent directory to trigger recompilation
+ sleep 2
+ echo "dummy" > TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Remove the file to check that recompilation is triggered
+ sleep 2
+ $(RM) TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Should not trigger recompilation
+ sleep 2
+ echo "dummy" > DONT_TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Should trigger a recompilation. Note that we should also see the change
+# in the non-dependent directory now, since it is still rechecked as long
+# as we recompile, it just doesn't *trigger* a recompilation.
+ sleep 2
+ rm -rf TRIGGER_RECOMP
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
T8333:
'$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(ghcThWayFlags) T8333.hs < /dev/null
=====================================
testsuite/tests/th/TH_Depends_Dir.hs
=====================================
@@ -0,0 +1,10 @@
+
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import TH_Depends_Dir_External (checkDirectoryContent)
+
+main :: IO ()
+main = do
+ print $checkDirectoryContent
=====================================
testsuite/tests/th/TH_Depends_Dir.stdout
=====================================
@@ -0,0 +1,5 @@
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory is non-empty, non-dependent directory is empty."
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory does not exist, non-dependent directory is non-empty."
=====================================
testsuite/tests/th/TH_Depends_Dir_External.hs
=====================================
@@ -0,0 +1,41 @@
+
+module TH_Depends_Dir_External where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+import System.Directory (listDirectory, doesDirectoryExist)
+
+-- | This function checks the contents of a dependent directory and a non-dependent directory.
+-- So its value will change if the contents of the dependent directory change.
+-- It will not change if the contents of the non-dependent directory change.
+checkDirectoryContent :: Q Exp
+checkDirectoryContent = do
+ let dependentDir = "TRIGGER_RECOMP"
+ let nonDependentDir = "DONT_TRIGGER_RECOMP"
+
+ -- this will error when dependentDir does not exist
+ -- which is the last thing we test for in the Makefile
+ exists <- qRunIO $ doesDirectoryExist dependentDir
+ dep_str <- if exists
+ then do
+ qAddDependentDirectory dependentDir
+ l <- qRunIO $ listDirectory dependentDir
+ case l of
+ [] -> pure "dependent directory is empty"
+ _ -> pure "dependent directory is non-empty"
+ else do
+ -- note that once we are here we no longer depend on the directory
+ -- so no more recompilation will happen.
+ pure "dependent directory does not exist"
+
+ -- Now the part that shouldn't trigger recompilation.
+ -- This is somewhat of a sanity check, if we change nonDependentDir
+ -- and it triggers recompilation, then something must be wrong
+ -- with the recompilation logic.
+ non_deps <- qRunIO $ listDirectory nonDependentDir
+ non_dep_str <- case non_deps of
+ [] -> pure "non-dependent directory is empty."
+ _ -> pure "non-dependent directory is non-empty."
+
+ -- Return the result as a string expression
+ stringE $ dep_str ++ ", " ++ non_dep_str
=====================================
testsuite/tests/th/all.T
=====================================
@@ -214,6 +214,7 @@ test('T5434', [], multimod_compile,
['T5434', '-v0 -Wall ' + config.ghc_th_way_flags])
test('T5508', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_Depends', [only_ways(['normal'])], makefile_test, ['TH_Depends'])
+test('TH_Depends_Dir', [only_ways(['normal']), js_skip], makefile_test, ['TH_Depends_Dir'])
test('T5597', [], multimod_compile, ['T5597', '-v0 ' + config.ghc_th_way_flags])
test('T5665', [], multimod_compile, ['T5665', '-v0 ' + config.ghc_th_way_flags])
test('T5700', [], multimod_compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae89f0006cb0221e54a6bcecfb15423…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ae89f0006cb0221e54a6bcecfb15423…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Import new name for 'utimbuf' on windows to fix #26337
by Marge Bot (＠marge-bot) 27 Aug '25
by Marge Bot (＠marge-bot) 27 Aug '25
27 Aug '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
f9f2ffcf by Alexandre Esteves at 2025-08-27T07:19:14-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
1 changed file:
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
Changes:
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
=====================================
@@ -97,7 +97,11 @@ data {-# CTYPE "struct stat" #-} CStat
data {-# CTYPE "struct termios" #-} CTermios
data {-# CTYPE "struct tm" #-} CTm
data {-# CTYPE "struct tms" #-} CTms
+#if defined(mingw32_HOST_OS)
+data {-# CTYPE "struct _utimbuf" #-} CUtimbuf
+#else
data {-# CTYPE "struct utimbuf" #-} CUtimbuf
+#endif
data {-# CTYPE "struct utsname" #-} CUtsname
type FD = CInt
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9f2ffcf8449dea2d3639b5aba25dbc…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f9f2ffcf8449dea2d3639b5aba25dbc…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/stack-annotation-with-backtraces] Expose Stack Annotation frames in IPE backtraces by default
by Hannes Siebenhandl (＠fendor) 27 Aug '25
by Hannes Siebenhandl (＠fendor) 27 Aug '25
27 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC
Commits:
25dc49c9 by fendor at 2025-08-27T11:48:43+02:00
Expose Stack Annotation frames in IPE backtraces by default
- - - - -
9 changed files:
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
- libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
=====================================
@@ -58,6 +58,7 @@ import Data.Typeable
import GHC.Exts
import GHC.IO
import GHC.Internal.Stack
+import GHC.Internal.Stack.Annotation
-- Note [User-defined stack annotations for better stack traces]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -127,31 +128,10 @@ import GHC.Internal.Stack
-- This means, right now, if you want to reliably capture stack frame annotations,
-- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'.
--- ----------------------------------------------------------------------------
--- StackAnnotation
--- ----------------------------------------------------------------------------
-
--- | 'StackAnnotation's are types which can be pushed onto the call stack
--- as the payload of 'AnnFrame' stack frames.
---
-class StackAnnotation a where
- displayStackAnnotation :: a -> String
-
-- ----------------------------------------------------------------------------
-- Annotations
-- ----------------------------------------------------------------------------
--- |
--- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
--- When the call stack is annotated with a value of type @a@, behind the scenes it is
--- encapsulated in a @SomeStackAnnotation@.
---
-data SomeStackAnnotation where
- SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
-
-instance StackAnnotation SomeStackAnnotation where
- displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
-
data StringAnnotation where
StringAnnotation :: String -> StringAnnotation
@@ -175,7 +155,7 @@ instance Show CallStackAnnotation where
instance StackAnnotation CallStackAnnotation where
displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of
[] -> "<unknown source location>"
- ((_,srcLoc):_) -> prettySrcLoc srcLoc
+ ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc
-- ----------------------------------------------------------------------------
-- Annotate the CallStack with custom data
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -295,6 +295,7 @@ Library
GHC.Internal.Stable
GHC.Internal.StableName
GHC.Internal.Stack
+ GHC.Internal.Stack.Annotation
GHC.Internal.Stack.CCS
GHC.Internal.Stack.CloneStack
GHC.Internal.Stack.Constants
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -11,7 +11,7 @@ import GHC.Internal.IORef
import GHC.Internal.IO.Unsafe (unsafePerformIO)
import GHC.Internal.Exception.Context
import GHC.Internal.Ptr
-import GHC.Internal.Data.Maybe (fromMaybe)
+import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
@@ -144,7 +144,7 @@ displayBacktraces bts = concat
displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
-- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
-- references closures can be garbage collected.
- displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
+ displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe
displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module GHC.Internal.Stack.Annotation where
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Typeable
+
+-- ----------------------------------------------------------------------------
+-- StackAnnotation
+-- ----------------------------------------------------------------------------
+
+-- | 'StackAnnotation's are types which can be pushed onto the call stack
+-- as the payload of 'AnnFrame' stack frames.
+--
+class StackAnnotation a where
+ displayStackAnnotation :: a -> String
+
+-- ----------------------------------------------------------------------------
+-- Annotations
+-- ----------------------------------------------------------------------------
+
+-- |
+-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
+-- When the call stack is annotated with a value of type @a@, behind the scenes it is
+-- encapsulated in a @SomeStackAnnotation@.
+--
+data SomeStackAnnotation where
+ SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
+
+instance StackAnnotation SomeStackAnnotation where
+ displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -23,6 +24,7 @@ module GHC.Internal.Stack.Decode (
StackEntry(..),
-- * Pretty printing
prettyStackEntry,
+ prettyStackFrameWithIpe,
)
where
@@ -39,6 +41,7 @@ import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
import GHC.Internal.Exts
+import GHC.Internal.Unsafe.Coerce
import GHC.Internal.ClosureTypes
import GHC.Internal.Heap.Closures
@@ -52,6 +55,7 @@ import GHC.Internal.Heap.Closures
)
import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Stack.Annotation
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.CloneStack
import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
@@ -560,6 +564,16 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
-- Pretty printing functions for stack entires, stack frames and provenance info
-- ----------------------------------------------------------------------------
+prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
+prettyStackFrameWithIpe (frame, mipe) =
+ case frame of
+ AnnFrame {annotation = Box someStackAnno } ->
+ case unsafeCoerce someStackAnno of
+ SomeStackAnnotation ann ->
+ Just $ displayStackAnnotation ann
+ _ ->
+ (prettyStackEntry . toStackEntry) <$> mipe
+
prettyStackEntry :: StackEntry -> String
prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
libraries/ghc-internal/tests/stack-annotation/ann_frame002.stdout
=====================================
@@ -1,11 +1,11 @@
Start some work
10946
Stack annotations:
-- ann_frame002.hs:18:7 in main:Main
-- ann_frame002.hs:12:11 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:18:7 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:12:11 in main:Main
Finish some work
Some more work in bar
17711
Stack annotations:
- bar
-- ann_frame002.hs:23:7 in main:Main
+- annotateCallStackIO, called at ann_frame002.hs:23:7 in main:Main
=====================================
libraries/ghc-internal/tests/stack-annotation/ann_frame004.stdout
=====================================
@@ -1,17 +1,17 @@
Stack annotations:
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:21:17 in main:Main
-- ann_frame004.hs:13:10 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:21:17 in main:Main
+- annotateCallStack, called at ann_frame004.hs:13:10 in main:Main
- bar
-- ann_frame004.hs:12:7 in main:Main
+- annotateCallStackIO, called at ann_frame004.hs:12:7 in main:Main
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -10949,10 +10949,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11151,3 +11147,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -10952,10 +10952,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11154,3 +11150,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25dc49c957e50b8e46defb29eec58ff…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25dc49c957e50b8e46defb29eec58ff…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
27 Aug '25
Simon Peyton Jones pushed to branch wip/T26346 at Glasgow Haskell Compiler / GHC
Commits:
632594f5 by Simon Peyton Jones at 2025-08-27T10:17:57+01:00
I think this works now
- - - - -
1 changed file:
- compiler/GHC/Core/Unify.hs
Changes:
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1792,12 +1792,12 @@ uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()
-- Why saturated? See (ATF4) in Note [Apartness and type families]
uVarOrFam env ty1 ty2 kco
= do { substs <- getSubstEnvs
- ; pprTrace "uVarOrFam" (vcat
- [ text "ty1" <+> ppr ty1
- , text "ty2" <+> ppr ty2
- , text "tv_env" <+> ppr (um_tv_env substs)
- , text "fam_env" <+> ppr (um_fam_env substs) ]) $
- go NotSwapped substs ty1 ty2 kco }
+-- ; pprTrace "uVarOrFam" (vcat
+-- [ text "ty1" <+> ppr ty1
+-- , text "ty2" <+> ppr ty2
+-- , text "tv_env" <+> ppr (um_tv_env substs)
+-- , text "fam_env" <+> ppr (um_fam_env substs) ]) $
+ ; go NotSwapped substs ty1 ty2 kco }
where
-- `go` takes two bites at the cherry; if the first one fails
-- it swaps the arguments and tries again; and then it fails.
@@ -1901,15 +1901,14 @@ uVarOrFam env ty1 ty2 kco
-- Check for equality F tys1 ~ F tys2
| Just (tc2, tys2) <- isSatFamApp ty2
, tc1 == tc2
- = go_fam_fam tc1 tys1 tys2 kco
+ = go_fam_fam substs tc1 tys1 tys2 kco
-- Now check if we can bind the (F tys) to the RHS
-- This can happen even when matching: see (ATF7)
| BindMe <- um_bind_fam_fun env tc1 tys1 rhs
= if uOccursCheck substs lhs rhs
then maybeApart MARInfinite
- else do { pprTrace "extend1" (ppr tc1 <+> ppr tys1 $$ ppr rhs) $
- extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13)
+ else do { extendFamEnv tc1 tys1 rhs -- We don't substitue tys1; see (ATF13)
; maybeApart MARTypeFamily }
-- Swap in case of (F a b) ~ (G c d e)
@@ -1930,7 +1929,7 @@ uVarOrFam env ty1 ty2 kco
-----------------------------
-- go_fam_fam: LHS and RHS are both saturated type-family applications,
-- for the same type-family F
- go_fam_fam tc tys1 tys2 kco
+ go_fam_fam substs tc tys1 tys2 kco
-- Decompose (F tys1 ~ F tys2): (ATF9)
-- Use injectivity information of F: (ATF10)
-- But first bind the type-fam if poss: (ATF11)
@@ -1950,14 +1949,12 @@ uVarOrFam env ty1 ty2 kco
bind_fam_if_poss
| not (um_unif env) -- Not when matching (ATF11-1)
= return ()
- | tcEqTyConAppArgs tys1 tys2 -- Detect (F tys ~ F tys);
- = return () -- otherwise we'd build an infinite substitution
| BindMe <- um_bind_fam_fun env tc tys1 rhs1
- = pprTrace "extend2" (ppr tc <+> ppr tys1 $$ ppr rhs1) $
+ = unless (uOccursCheck substs (TyFamLHS tc tys1) rhs1) $
extendFamEnv tc tys1 rhs1
- | um_unif env
- , BindMe <- um_bind_fam_fun env tc tys2 rhs2
- = pprTrace "extend3" (ppr tc <+> ppr tys2 $$ ppr rhs2) $
+ -- At this point um_unif=True, so we can unify either way
+ | BindMe <- um_bind_fam_fun env tc tys2 rhs2
+ = unless (uOccursCheck substs (TyFamLHS tc tys2) rhs2) $
extendFamEnv tc tys2 rhs2
| otherwise
= return ()
@@ -1967,14 +1964,13 @@ uVarOrFam env ty1 ty2 kco
uOccursCheck :: UMState -> CanEqLHS -> Type -> Bool
--- See Note [The occurs check in the Core unifier] and (ATF13)
+-- See Note [The occurs check in the Core unifier] and (ATF14)
uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty
= go emptyVarSet ty
where
go :: TyCoVarSet -- Bound by enclosing foralls
-> Type -> Bool
- go bvs ty | Just ty' <- pprTrace "uOccursCheck:go" (ppr lhs $$ ppr ty) $
- coreView ty = go bvs ty'
+ go bvs ty | Just ty' <- coreView ty = go bvs ty'
go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv
= go bvs ty'
| TyVarLHS tv' <- lhs, tv==tv'
@@ -1999,8 +1995,7 @@ uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) lhs ty
go_tc bvs tc tys
| isTypeFamilyTyCon tc
, Just ty' <- lookupFamEnv fam_env tc (take arity tys)
- = pprTrace "lookup" (ppr tc <+> ppr tys $$ ppr ty') $
- go bvs ty' || any (go bvs) (drop arity tys)
+ = go bvs ty' || any (go bvs) (drop arity tys)
| TyFamLHS tc' tys' <- lhs
, tc == tc'
@@ -2168,7 +2163,6 @@ extendCvEnv cv co = UM $ \state ->
extendFamEnv :: TyCon -> [Type] -> Type -> UM ()
extendFamEnv tc tys ty = UM $ \state ->
- pprTrace "Adding fam env" (ppr tc <+> ppr tys $$ text ":->" <+> ppr ty) $
Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ())
where
extend :: FamSubstEnv -> TyCon -> FamSubstEnv
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/632594f5764e01658543b3af842c8ef…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/632594f5764e01658543b3af842c8ef…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/stack-annotation-with-backtraces] Expose Stack Annotation frames in IPE backtraces by default
by Hannes Siebenhandl (＠fendor) 27 Aug '25
by Hannes Siebenhandl (＠fendor) 27 Aug '25
27 Aug '25
Hannes Siebenhandl pushed to branch wip/fendor/stack-annotation-with-backtraces at Glasgow Haskell Compiler / GHC
Commits:
ff5cf2e5 by fendor at 2025-08-27T09:34:03+02:00
Expose Stack Annotation frames in IPE backtraces by default
- - - - -
7 changed files:
- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
Changes:
=====================================
libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
=====================================
@@ -58,6 +58,7 @@ import Data.Typeable
import GHC.Exts
import GHC.IO
import GHC.Internal.Stack
+import GHC.Internal.Stack.Annotation
-- Note [User-defined stack annotations for better stack traces]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -127,31 +128,10 @@ import GHC.Internal.Stack
-- This means, right now, if you want to reliably capture stack frame annotations,
-- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'.
--- ----------------------------------------------------------------------------
--- StackAnnotation
--- ----------------------------------------------------------------------------
-
--- | 'StackAnnotation's are types which can be pushed onto the call stack
--- as the payload of 'AnnFrame' stack frames.
---
-class StackAnnotation a where
- displayStackAnnotation :: a -> String
-
-- ----------------------------------------------------------------------------
-- Annotations
-- ----------------------------------------------------------------------------
--- |
--- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
--- When the call stack is annotated with a value of type @a@, behind the scenes it is
--- encapsulated in a @SomeStackAnnotation@.
---
-data SomeStackAnnotation where
- SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
-
-instance StackAnnotation SomeStackAnnotation where
- displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
-
data StringAnnotation where
StringAnnotation :: String -> StringAnnotation
@@ -175,7 +155,7 @@ instance Show CallStackAnnotation where
instance StackAnnotation CallStackAnnotation where
displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of
[] -> "<unknown source location>"
- ((_,srcLoc):_) -> prettySrcLoc srcLoc
+ ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc srcLoc
-- ----------------------------------------------------------------------------
-- Annotate the CallStack with custom data
=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -295,6 +295,7 @@ Library
GHC.Internal.Stable
GHC.Internal.StableName
GHC.Internal.Stack
+ GHC.Internal.Stack.Annotation
GHC.Internal.Stack.CCS
GHC.Internal.Stack.CloneStack
GHC.Internal.Stack.Constants
=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -11,7 +11,7 @@ import GHC.Internal.IORef
import GHC.Internal.IO.Unsafe (unsafePerformIO)
import GHC.Internal.Exception.Context
import GHC.Internal.Ptr
-import GHC.Internal.Data.Maybe (fromMaybe)
+import GHC.Internal.Data.Maybe (fromMaybe, mapMaybe)
import GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Internal.Stack as HCS
import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
@@ -144,7 +144,7 @@ displayBacktraces bts = concat
displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
-- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
-- references closures can be garbage collected.
- displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
+ displayIpe = unlines . mapMaybe (fmap (indent 2) . CloneStack.prettyStackFrameWithIpe) . unsafePerformIO . CloneStack.decodeStackWithIpe
displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module GHC.Internal.Stack.Annotation where
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Typeable
+
+-- ----------------------------------------------------------------------------
+-- StackAnnotation
+-- ----------------------------------------------------------------------------
+
+-- | 'StackAnnotation's are types which can be pushed onto the call stack
+-- as the payload of 'AnnFrame' stack frames.
+--
+class StackAnnotation a where
+ displayStackAnnotation :: a -> String
+
+-- ----------------------------------------------------------------------------
+-- Annotations
+-- ----------------------------------------------------------------------------
+
+-- |
+-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
+-- When the call stack is annotated with a value of type @a@, behind the scenes it is
+-- encapsulated in a @SomeStackAnnotation@.
+--
+data SomeStackAnnotation where
+ SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation
+
+instance StackAnnotation SomeStackAnnotation where
+ displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -23,6 +24,7 @@ module GHC.Internal.Stack.Decode (
StackEntry(..),
-- * Pretty printing
prettyStackEntry,
+ prettyStackFrameWithIpe,
)
where
@@ -39,6 +41,7 @@ import GHC.Internal.Data.Tuple
import GHC.Internal.Foreign.Ptr
import GHC.Internal.Foreign.Storable
import GHC.Internal.Exts
+import GHC.Internal.Unsafe.Coerce
import GHC.Internal.ClosureTypes
import GHC.Internal.Heap.Closures
@@ -52,6 +55,7 @@ import GHC.Internal.Heap.Closures
)
import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Stack.Annotation
import GHC.Internal.Stack.Constants
import GHC.Internal.Stack.CloneStack
import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE)
@@ -560,6 +564,16 @@ decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
-- Pretty printing functions for stack entires, stack frames and provenance info
-- ----------------------------------------------------------------------------
+prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
+prettyStackFrameWithIpe (frame, mipe) =
+ case frame of
+ AnnFrame {annotation = Box someStackAnno } ->
+ case unsafeCoerce someStackAnno of
+ SomeStackAnnotation ann ->
+ Just $ displayStackAnnotation ann
+ _ ->
+ (prettyStackEntry . toStackEntry) <$> mipe
+
prettyStackEntry :: StackEntry -> String
prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -10949,10 +10949,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11151,3 +11147,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout-mingw32
=====================================
@@ -10952,10 +10952,6 @@ module System.Mem.Experimental where
-- Instances:
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.SomeStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
-instance GHC.Stack.Annotation.Experimental.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Base.Alternative GHC.Internal.Types.IO -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative [] -- Defined in ‘GHC.Internal.Base’
instance GHC.Internal.Base.Alternative GHC.Internal.Maybe.Maybe -- Defined in ‘GHC.Internal.Base’
@@ -11154,3 +11150,7 @@ instance GHC.Internal.Show.Show GHC.Internal.IO.SubSystem.IoSubSystem -- Defined
instance GHC.Internal.Show.Show GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
instance GHC.Internal.Show.Show GHC.Internal.Stats.GCDetails -- Defined in ‘GHC.Internal.Stats’
instance GHC.Internal.Show.Show GHC.Internal.Stats.RTSStats -- Defined in ‘GHC.Internal.Stats’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.CallStackAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.ShowAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Stack.Annotation.Experimental.StringAnnotation -- Defined in ‘GHC.Stack.Annotation.Experimental’
+instance GHC.Internal.Stack.Annotation.StackAnnotation GHC.Internal.Stack.Annotation.SomeStackAnnotation -- Defined in ‘GHC.Internal.Stack.Annotation’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff5cf2e58c615f9c894e84f020f1ff2…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ff5cf2e58c615f9c894e84f020f1ff2…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Import new name for 'utimbuf' on windows to fix #26337
by Marge Bot (＠marge-bot) 27 Aug '25
by Marge Bot (＠marge-bot) 27 Aug '25
27 Aug '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
8b3e3ac0 by Alexandre Esteves at 2025-08-27T00:08:36-04:00
Import new name for 'utimbuf' on windows to fix #26337
Fixes an `-Wincompatible-pointer-types` instance that turns into an error on
recent toolchains and surfaced as such on nixpkgs when doing linux->ucrt cross.
This long-standing warning has been present at least since 9.4:
```
C:\GitLabRunner\builds\0\1709189\tmp\ghc16652_0\ghc_4.c:26:115: error:
warning: incompatible pointer types passing 'struct utimbuf *' to parameter of type 'struct _utimbuf *' [-Wincompatible-pointer-types]
|
26 | HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
| ^
HsInt32 ghczuwrapperZC9ZCbaseZCSystemziPosixziInternalsZCzuutime(char* a1, struct utimbuf* a2) {return _utime(a1, a2);}
^~
C:\GitLabRunner\builds\0\1709189\_build\stage0\lib\..\..\mingw\x86_64-w64-mingw32\include\sys\utime.h:109:72: error:
note: passing argument to parameter '_Utimbuf' here
|
109 | __CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
| ^
__CRT_INLINE int __cdecl _utime(const char *_Filename,struct _utimbuf *_Utimbuf) {
```
- - - - -
86ce75c6 by Hassan Al-Awwadi at 2025-08-27T00:08:37-04:00
Adds the fucnction addDependentDirectory to Q, resolving issue #26148.
This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide.
- - - - -
24 changed files:
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Recomp/Types.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/Finder/Types.hs
- compiler/GHC/Unit/Module/Deps.hs
- docs/users_guide/9.16.1-notes.rst
- docs/users_guide/separate_compilation.rst
- libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
- libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/TH.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- testsuite/.gitignore
- testsuite/tests/interface-stability/template-haskell-exports.stdout
- testsuite/tests/th/Makefile
- + testsuite/tests/th/TH_Depends_Dir.hs
- + testsuite/tests/th/TH_Depends_Dir.stdout
- + testsuite/tests/th/TH_Depends_Dir_External.hs
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -75,14 +75,15 @@ data UsageConfig = UsageConfig
mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv
-> Module -> ImportedMods -> [ImportUserSpec] -> NameSet
- -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
+ -> [FilePath] -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded
-> IfG [Usage]
mkUsageInfo uc plugins fc unit_env
this_mod dir_imp_mods imp_decls used_names
- dependent_files merged needed_links needed_pkgs
+ dependent_files dependent_dirs merged needed_links needed_pkgs
= do
eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env))
- hashes <- liftIO $ mapM getFileHash dependent_files
+ file_hashes <- liftIO $ mapM getFileHash dependent_files
+ dirs_hashes <- liftIO $ mapM getDirHash dependent_dirs
let hu = ue_unsafeHomeUnit unit_env
hug = ue_home_unit_graph unit_env
-- Dependencies on object files due to TH and plugins
@@ -93,7 +94,11 @@ mkUsageInfo uc plugins fc unit_env
let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f
, usg_file_hash = hash
, usg_file_label = Nothing }
- | (f, hash) <- zip dependent_files hashes ]
+ | (f, hash) <- zip dependent_files file_hashes ]
+ ++ [ UsageDirectory { usg_dir_path = mkFastString d
+ , usg_dir_hash = hash
+ , usg_dir_label = Nothing }
+ | (d, hash) <- zip dependent_dirs dirs_hashes]
++ [ UsageMergedRequirement
{ usg_mod = mod,
usg_mod_hash = hash
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -269,6 +269,7 @@ mkRecompUsageInfo hsc_env tc_result = do
else do
let used_names = mkUsedNames tc_result
dep_files <- (readIORef (tcg_dependent_files tc_result))
+ dep_dirs <- (readIORef (tcg_dependent_dirs tc_result))
(needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)
let uc = initUsageConfig hsc_env
plugins = hsc_plugins hsc_env
@@ -289,6 +290,7 @@ mkRecompUsageInfo hsc_env tc_result = do
(tcg_import_decls tc_result)
used_names
dep_files
+ dep_dirs
(tcg_merged tc_result)
needed_links
needed_pkgs
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -194,6 +194,7 @@ data RecompReason
| ModuleChangedRaw ModuleName
| ModuleChangedIface ModuleName
| FileChanged FilePath
+ | DirChanged FilePath
| CustomReason String
| FlagsChanged
| LinkFlagsChanged
@@ -230,6 +231,7 @@ instance Outputable RecompReason where
ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed"
ModuleAdded (_st, _uid, m) -> ppr m <+> text "added"
FileChanged fp -> text fp <+> text "changed"
+ DirChanged dp -> text "Contents of" <+> text dp <+> text "changed"
CustomReason s -> text s
FlagsChanged -> text "Flags changed"
LinkFlagsChanged -> text "Flags changed"
@@ -815,6 +817,22 @@ checkModUsage fc UsageFile{ usg_file_path = file,
then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
else \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+checkModUsage fc UsageDirectory{ usg_dir_path = dir,
+ usg_dir_hash = old_hash,
+ usg_dir_label = mlabel } =
+ liftIO $
+ handleIO handler $ do
+ new_hash <- lookupDirCache fc $ unpackFS dir
+ if (old_hash /= new_hash)
+ then return recomp
+ else return UpToDate
+ where
+ reason = DirChanged $ unpackFS dir
+ recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
+ handler = if debugIsOn
+ then \e -> pprTrace "UsageDirectory" (text (show e)) $ return recomp
+ else \_ -> return recomp -- if we can't find the dir, just recompile, don't fail
+
-- | We are importing a module whose exports have changed.
-- Does this require recompilation?
--
=====================================
compiler/GHC/Iface/Recomp/Types.hs
=====================================
@@ -140,6 +140,10 @@ pprUsage usage@UsageFile{}
= hsep [text "addDependentFile",
doubleQuotes (ftext (usg_file_path usage)),
ppr (usg_file_hash usage)]
+pprUsage usage@UsageDirectory{}
+ = hsep [text "AddDependentDirectory",
+ doubleQuotes (ftext (usg_dir_path usage)),
+ ppr (usg_dir_hash usage)]
pprUsage usage@UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
pprUsage usage@UsageHomeModuleInterface{}
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -173,8 +173,6 @@ import GHC.Parser.HaddockLex (lexHsDoc)
import GHC.Parser (parseIdentifier)
import GHC.Rename.Doc (rnHsDoc)
-
-
{-
Note [Template Haskell state diagram]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1524,6 +1522,11 @@ instance TH.Quasi TcM where
dep_files <- readTcRef ref
writeTcRef ref (fp:dep_files)
+ qAddDependentDirectory dp = do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (dp:dep_dirs)
+
qAddTempFile suffix = do
dflags <- getDynFlags
logger <- getLogger
@@ -1928,6 +1931,7 @@ handleTHMessage msg = case msg of
ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+ AddDependentDirectory d -> wrapTHResult $ TH.qAddDependentDirectory d
AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
AddModFinalizer r -> do
interp <- hscInterp <$> getTopEnv
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -603,6 +603,7 @@ data TcGblEnv
-- decls.
tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile
+ tcg_dependent_dirs :: TcRef [FilePath], -- ^ dependencies from addDependentDirectory
tcg_th_topdecls :: TcRef [LHsDecl GhcPs],
-- ^ Top-level declarations from addTopDecls
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad(
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv,
getDeclaredDefaultTys,
- addDependentFiles,
+ addDependentFiles, addDependentDirectories,
-- * Error management
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
@@ -273,6 +273,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
let { type_env_var = hsc_type_env_vars hsc_env };
dependent_files_var <- newIORef [] ;
+ dependent_dirs_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
cc_st_var <- newIORef newCostCentreState ;
th_topdecls_var <- newIORef [] ;
@@ -368,6 +369,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_safe_infer = infer_var,
tcg_safe_infer_reasons = infer_reasons_var,
tcg_dependent_files = dependent_files_var,
+ tcg_dependent_dirs = dependent_dirs_var,
tcg_tc_plugin_solvers = [],
tcg_tc_plugin_rewriters = emptyUFM,
tcg_defaulting_plugins = [],
@@ -956,6 +958,12 @@ addDependentFiles fs = do
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
+addDependentDirectories :: [FilePath] -> TcRn ()
+addDependentDirectories ds = do
+ ref <- fmap tcg_dependent_dirs getGblEnv
+ dep_dirs <- readTcRef ref
+ writeTcRef ref (ds ++ dep_dirs)
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Unit/Finder.hs
=====================================
@@ -31,6 +31,9 @@ module GHC.Unit.Finder (
findObjectLinkableMaybe,
findObjectLinkable,
+
+ -- important that GHC.HsToCore.Usage uses the same hashing method for usage dirs as is used here.
+ getDirHash,
) where
import GHC.Prelude
@@ -69,7 +72,9 @@ import GHC.Types.Unique.Map
import GHC.Driver.Env
import GHC.Driver.Config.Finder
import GHC.Types.Unique.Set
+import qualified Data.List as L(sort)
import Data.List.NonEmpty ( NonEmpty (..) )
+import qualified System.Directory as SD
import qualified System.OsPath as OsPath
import qualified Data.List.NonEmpty as NE
@@ -108,10 +113,12 @@ initFinderCache :: IO FinderCache
initFinderCache = do
mod_cache <- newIORef emptyInstalledModuleEnv
file_cache <- newIORef M.empty
+ dir_cache <- newIORef M.empty
let flushFinderCaches :: UnitEnv -> IO ()
flushFinderCaches ue = do
atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
atomicModifyIORef' file_cache $ \_ -> (M.empty, ())
+ atomicModifyIORef' dir_cache $ \_ -> (M.empty, ())
where
is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
@@ -138,8 +145,27 @@ initFinderCache = do
atomicModifyIORef' file_cache $ \c -> (M.insert key hash c, ())
return hash
Just fp -> return fp
+ lookupDirCache :: FilePath -> IO Fingerprint
+ lookupDirCache key = do
+ c <- readIORef dir_cache
+ case M.lookup key c of
+ Nothing -> do
+ hash <- getDirHash key
+ atomicModifyIORef' dir_cache $ \c -> (M.insert key hash c, ())
+ return hash
+ Just fp -> return fp
return FinderCache{..}
+-- | This function computes a shallow hash of a directory, so really just what files and directories are directly inside it.
+-- It does not look at the contents of the files, or the contents of the directories it contains.
+getDirHash :: FilePath -> IO Fingerprint
+getDirHash dir = do
+ contents <- SD.listDirectory dir
+ let hashes = fingerprintString <$> contents
+ let s_hashes = L.sort hashes
+ let hash = fingerprintFingerprints s_hashes
+ return hash
+
-- -----------------------------------------------------------------------------
-- The three external entry points
=====================================
compiler/GHC/Unit/Finder/Types.hs
=====================================
@@ -38,6 +38,7 @@ data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO ()
, lookupFileCache :: FilePath -> IO Fingerprint
-- ^ Look for the hash of a file in the cache. This should add it to the
-- cache. If the file doesn't exist, raise an IOException.
+ , lookupDirCache :: FilePath -> IO Fingerprint
}
data InstalledFindResult
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -357,6 +357,23 @@ data Usage
-- contents don't change. This previously lead to odd
-- recompilation behaviors; see #8114
}
+ | UsageDirectory {
+ usg_dir_path :: FastString,
+ -- ^ External dir dependency. From TH addDependentFile.
+ -- Should be absolute.
+ usg_dir_hash :: Fingerprint,
+ -- ^ 'Fingerprint' of the directories contents.
+
+ usg_dir_label :: Maybe String
+ -- ^ An optional string which is used in recompilation messages if
+ -- dir in question has changed.
+
+ -- Note: We do a very shallow check indeed, just what the contents of
+ -- the directory are, aka what files and directories are within it.
+ -- If those files/directories have their own contents changed, then
+ -- we won't spot it here. If you do want to spot that, the caller
+ -- should recursively add them to their useage.
+ }
| UsageHomeModuleInterface {
usg_mod_name :: ModuleName
-- ^ Name of the module
@@ -395,6 +412,7 @@ instance NFData Usage where
rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` ()
rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` ()
rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` ()
+ rnf (UsageDirectory dir hash label) = rnf dir `seq` rnf hash `seq` rnf label `seq` ()
rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` ()
rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` ()
@@ -431,6 +449,12 @@ instance Binary Usage where
put_ bh (usg_unit_id usg)
put_ bh (usg_iface_hash usg)
+ put_ bh usg@UsageDirectory{} = do
+ putByte bh 5
+ put_ bh (usg_dir_path usg)
+ put_ bh (usg_dir_hash usg)
+ put_ bh (usg_dir_label usg)
+
get bh = do
h <- getByte bh
case h of
@@ -462,6 +486,12 @@ instance Binary Usage where
uid <- get bh
hash <- get bh
return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash }
+ 5 -> do
+ dp <- get bh
+ hash <- get bh
+ label <- get bh
+ return UsageDirectory { usg_dir_path = dp, usg_dir_hash = hash, usg_dir_label = label }
+
i -> error ("Binary.get(Usage): " ++ show i)
-- | Records the imports that we depend on from a home module,
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -55,6 +55,11 @@ Cmm
``template-haskell`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+- We have added the ``addDependentDirectory`` function to match
+ ``addDependentFile``, which adds a directory to the list of dependencies that
+ the recompilation checker will look at to determine if a module needs to be
+ recompiled.
+
Included libraries
~~~~~~~~~~~~~~~~~~
=====================================
docs/users_guide/separate_compilation.rst
=====================================
@@ -710,7 +710,7 @@ beautiful sight!
You can read about :ghc-wiki:`how all this works <commentary/compiler/recompilation-avoidance>` in the GHC commentary.
Recompilation for Template Haskell and Plugins
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Recompilation checking gets a bit more complicated when using Template Haskell or
plugins. Both these features execute code at compile time and so if any of the
@@ -727,6 +727,19 @@ if ``foo`` is from module ``A`` and ``bar`` is from module ``B``, the module wil
now depend on ``A.o`` and ``B.o``, if either of these change then the module will
be recompiled.
+``addDependentFile`` and ``addDependentDirectory``
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+When using Template Haskell or plugins, you can use the functions
+``addDependentFile`` and ``addDependentDirectory`` to add additional
+dependencies to the module being compiled.
+
+- When adding a file, this means that the contents of the file changing between
+ compilations will trigger a recompilation of the module.
+- When adding a directory, this means that any file or subdirectory *added* to or
+ *removed* from the directory will trigger recompilation of the module, so
+ it is not a recursive dependency.
+
.. _mutual-recursion:
Mutually recursive modules and hs-boot files
=====================================
libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs
=====================================
@@ -97,7 +97,11 @@ data {-# CTYPE "struct stat" #-} CStat
data {-# CTYPE "struct termios" #-} CTermios
data {-# CTYPE "struct tm" #-} CTm
data {-# CTYPE "struct tms" #-} CTms
+#if defined(mingw32_HOST_OS)
+data {-# CTYPE "struct _utimbuf" #-} CUtimbuf
+#else
data {-# CTYPE "struct utimbuf" #-} CUtimbuf
+#endif
data {-# CTYPE "struct utsname" #-} CUtsname
type FD = CInt
=====================================
libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs
=====================================
@@ -132,6 +132,9 @@ class (MonadIO m, MonadFail m) => Quasi m where
-- | See 'addDependentFile'.
qAddDependentFile :: FilePath -> m ()
+ -- | See 'addDependentDirectory'.
+ qAddDependentDirectory :: FilePath -> m ()
+
-- | See 'addTempFile'.
qAddTempFile :: String -> m FilePath
@@ -202,6 +205,7 @@ instance Quasi IO where
qExtsEnabled = badIO "extsEnabled"
qPutDoc _ _ = badIO "putDoc"
qGetDoc _ = badIO "getDoc"
+ qAddDependentDirectory _ = badIO "AddDependentDirectory"
instance Quote IO where
newName = newNameIO
@@ -819,6 +823,24 @@ getPackageRoot :: Q FilePath
getPackageRoot = Q qGetPackageRoot
+-- | Record external directories that runIO is using (dependent upon).
+-- The compiler can then recognize that it should re-compile the Haskell file
+-- when a directory changes.
+--
+-- Notes:
+--
+-- * ghc -M does not know about these dependencies - it does not execute TH.
+--
+-- * The dependency is shallow, based only on the direct content.
+-- Basically, it only sees a list of names. It does not look at directory
+-- metadata, recurse into subdirectories, or look at file contents. As
+-- long as the list of names remains the same, the directory is considered
+-- unchanged.
+--
+-- * The state of the directory is read at the interface generation time,
+-- not at the time of the function call.
+addDependentDirectory :: FilePath -> Q ()
+addDependentDirectory dp = Q (qAddDependentDirectory dp)
-- | Record external files that runIO is using (dependent upon).
-- The compiler can then recognize that it should re-compile the Haskell file
@@ -830,7 +852,11 @@ getPackageRoot = Q qGetPackageRoot
--
-- * ghc -M does not know about these dependencies - it does not execute TH.
--
--- * The dependency is based on file content, not a modification time
+-- * The dependency is based on file content, not a modification time or
+-- any other metadata associated with the file (e.g. permissions).
+--
+-- * The state of the file is read at the interface generation time,
+-- not at the time of the function call.
addDependentFile :: FilePath -> Q ()
addDependentFile fp = Q (qAddDependentFile fp)
@@ -952,32 +978,33 @@ instance MonadIO Q where
liftIO = runIO
instance Quasi Q where
- qNewName = newName
- qReport = report
- qRecover = recover
- qReify = reify
- qReifyFixity = reifyFixity
- qReifyType = reifyType
- qReifyInstances = reifyInstances
- qReifyRoles = reifyRoles
- qReifyAnnotations = reifyAnnotations
- qReifyModule = reifyModule
- qReifyConStrictness = reifyConStrictness
- qLookupName = lookupName
- qLocation = location
- qGetPackageRoot = getPackageRoot
- qAddDependentFile = addDependentFile
- qAddTempFile = addTempFile
- qAddTopDecls = addTopDecls
- qAddForeignFilePath = addForeignFilePath
- qAddModFinalizer = addModFinalizer
- qAddCorePlugin = addCorePlugin
- qGetQ = getQ
- qPutQ = putQ
- qIsExtEnabled = isExtEnabled
- qExtsEnabled = extsEnabled
- qPutDoc = putDoc
- qGetDoc = getDoc
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyFixity = reifyFixity
+ qReifyType = reifyType
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qReifyConStrictness = reifyConStrictness
+ qLookupName = lookupName
+ qLocation = location
+ qGetPackageRoot = getPackageRoot
+ qAddDependentFile = addDependentFile
+ qAddDependentDirectory = addDependentDirectory
+ qAddTempFile = addTempFile
+ qAddTopDecls = addTopDecls
+ qAddForeignFilePath = addForeignFilePath
+ qAddModFinalizer = addModFinalizer
+ qAddCorePlugin = addCorePlugin
+ qGetQ = getQ
+ qPutQ = putQ
+ qIsExtEnabled = isExtEnabled
+ qExtsEnabled = extsEnabled
+ qPutDoc = putDoc
+ qGetDoc = getDoc
----------------------------------------------------
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -291,6 +291,7 @@ data THMessage a where
GetPackageRoot :: THMessage (THResult FilePath)
AddDependentFile :: FilePath -> THMessage (THResult ())
+ AddDependentDirectory :: FilePath -> THMessage (THResult ())
AddTempFile :: String -> THMessage (THResult FilePath)
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddCorePlugin :: String -> THMessage (THResult ())
@@ -343,6 +344,7 @@ getTHMessage = do
23 -> THMsg <$> (PutDoc <$> get <*> get)
24 -> THMsg <$> GetDoc <$> get
25 -> THMsg <$> return GetPackageRoot
+ 26 -> THMsg <$> AddDependentDirectory <$> get
n -> error ("getTHMessage: unknown message " ++ show n)
putTHMessage :: THMessage a -> Put
@@ -373,7 +375,7 @@ putTHMessage m = case m of
PutDoc l s -> putWord8 23 >> put l >> put s
GetDoc l -> putWord8 24 >> put l
GetPackageRoot -> putWord8 25
-
+ AddDependentDirectory a -> putWord8 26 >> put a
data EvalOpts = EvalOpts
{ useSandboxThread :: Bool
=====================================
libraries/ghci/GHCi/TH.hs
=====================================
@@ -195,6 +195,7 @@ instance TH.Quasi GHCiQ where
qLocation = fromMaybe noLoc . qsLocation <$> getState
qGetPackageRoot = ghcCmd GetPackageRoot
qAddDependentFile file = ghcCmd (AddDependentFile file)
+ qAddDependentDirectory dir = ghcCmd (AddDependentDirectory dir)
qAddTempFile suffix = ghcCmd (AddTempFile suffix)
qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -34,6 +34,7 @@ module Language.Haskell.TH.Syntax (
ModName (..),
addCorePlugin,
addDependentFile,
+ addDependentDirectory,
addForeignFile,
addForeignFilePath,
addForeignSource,
=====================================
testsuite/.gitignore
=====================================
@@ -1523,6 +1523,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
/tests/th/T8633
/tests/th/TH_Depends
/tests/th/TH_Depends_external.txt
+/tests/th/TH_Depends_external/dummy.txt
/tests/th/TH_StringPrimL
/tests/th/TH_import_loop/ModuleA.hi-boot
/tests/th/TH_import_loop/ModuleA.o-boot
=====================================
testsuite/tests/interface-stability/template-haskell-exports.stdout
=====================================
@@ -1717,6 +1717,7 @@ module Language.Haskell.TH.Syntax where
qRunIO :: forall a. GHC.Internal.Types.IO a -> m a
qGetPackageRoot :: m GHC.Internal.IO.FilePath
qAddDependentFile :: GHC.Internal.IO.FilePath -> m ()
+ qAddDependentDirectory :: GHC.Internal.IO.FilePath -> m ()
qAddTempFile :: GHC.Internal.Base.String -> m GHC.Internal.IO.FilePath
qAddTopDecls :: [Dec] -> m ()
qAddForeignFilePath :: ForeignSrcLang -> GHC.Internal.Base.String -> m ()
@@ -1728,7 +1729,7 @@ module Language.Haskell.TH.Syntax where
qExtsEnabled :: m [Extension]
qPutDoc :: DocLoc -> GHC.Internal.Base.String -> m ()
qGetDoc :: DocLoc -> m (GHC.Internal.Maybe.Maybe GHC.Internal.Base.String)
- {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
+ {-# MINIMAL qNewName, qReport, qRecover, qLookupName, qReify, qReifyFixity, qReifyType, qReifyInstances, qReifyRoles, qReifyAnnotations, qReifyModule, qReifyConStrictness, qLocation, qGetPackageRoot, qAddDependentFile, qAddDependentDirectory, qAddTempFile, qAddTopDecls, qAddForeignFilePath, qAddModFinalizer, qAddCorePlugin, qGetQ, qPutQ, qIsExtEnabled, qExtsEnabled, qPutDoc, qGetDoc #-}
type Quote :: (* -> *) -> Constraint
class GHC.Internal.Base.Monad m => Quote m where
newName :: GHC.Internal.Base.String -> m Name
@@ -1781,6 +1782,7 @@ module Language.Haskell.TH.Syntax where
type VarStrictType :: *
type VarStrictType = VarBangType
addCorePlugin :: GHC.Internal.Base.String -> Q ()
+ addDependentDirectory :: GHC.Internal.IO.FilePath -> Q ()
addDependentFile :: GHC.Internal.IO.FilePath -> Q ()
addForeignFile :: ForeignSrcLang -> GHC.Internal.Base.String -> Q ()
addForeignFilePath :: ForeignSrcLang -> GHC.Internal.IO.FilePath -> Q ()
=====================================
testsuite/tests/th/Makefile
=====================================
@@ -43,6 +43,46 @@ TH_Depends:
'$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends
./TH_Depends
+.PHONY: TH_Depends_Dir
+TH_Depends_Dir:
+ rm -rf TRIGGER_RECOMP
+ rm -rf DONT_TRIGGER_RECOMP
+ $(RM) TH_Depends_Dir TH_Depends_Dir.exe
+ $(RM) TH_Depends_Dir.o TH_Depends_Dir.hi
+ $(RM) TH_Depends_Dir_External.o TH_Depends_Dir_External.hi
+
+ mkdir TRIGGER_RECOMP
+ mkdir DONT_TRIGGER_RECOMP
+
+# First build with an empty dependent directory
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Create a file in the dependent directory to trigger recompilation
+ sleep 2
+ echo "dummy" > TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Remove the file to check that recompilation is triggered
+ sleep 2
+ $(RM) TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Should not trigger recompilation
+ sleep 2
+ echo "dummy" > DONT_TRIGGER_RECOMP/dummy.txt
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
+
+# Should trigger a recompilation. Note that we should also see the change
+# in the non-dependent directory now, since it is still rechecked as long
+# as we recompile, it just doesn't *trigger* a recompilation.
+ sleep 2
+ rm -rf TRIGGER_RECOMP
+ '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -package directory -package template-haskell -v0 TH_Depends_Dir
+ ./TH_Depends_Dir
T8333:
'$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(ghcThWayFlags) T8333.hs < /dev/null
=====================================
testsuite/tests/th/TH_Depends_Dir.hs
=====================================
@@ -0,0 +1,10 @@
+
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import TH_Depends_Dir_External (checkDirectoryContent)
+
+main :: IO ()
+main = do
+ print $checkDirectoryContent
=====================================
testsuite/tests/th/TH_Depends_Dir.stdout
=====================================
@@ -0,0 +1,5 @@
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory is non-empty, non-dependent directory is empty."
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory is empty, non-dependent directory is empty."
+"dependent directory does not exist, non-dependent directory is non-empty."
=====================================
testsuite/tests/th/TH_Depends_Dir_External.hs
=====================================
@@ -0,0 +1,41 @@
+
+module TH_Depends_Dir_External where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Lib
+import System.Directory (listDirectory, doesDirectoryExist)
+
+-- | This function checks the contents of a dependent directory and a non-dependent directory.
+-- So its value will change if the contents of the dependent directory change.
+-- It will not change if the contents of the non-dependent directory change.
+checkDirectoryContent :: Q Exp
+checkDirectoryContent = do
+ let dependentDir = "TRIGGER_RECOMP"
+ let nonDependentDir = "DONT_TRIGGER_RECOMP"
+
+ -- this will error when dependentDir does not exist
+ -- which is the last thing we test for in the Makefile
+ exists <- qRunIO $ doesDirectoryExist dependentDir
+ dep_str <- if exists
+ then do
+ qAddDependentDirectory dependentDir
+ l <- qRunIO $ listDirectory dependentDir
+ case l of
+ [] -> pure "dependent directory is empty"
+ _ -> pure "dependent directory is non-empty"
+ else do
+ -- note that once we are here we no longer depend on the directory
+ -- so no more recompilation will happen.
+ pure "dependent directory does not exist"
+
+ -- Now the part that shouldn't trigger recompilation.
+ -- This is somewhat of a sanity check, if we change nonDependentDir
+ -- and it triggers recompilation, then something must be wrong
+ -- with the recompilation logic.
+ non_deps <- qRunIO $ listDirectory nonDependentDir
+ non_dep_str <- case non_deps of
+ [] -> pure "non-dependent directory is empty."
+ _ -> pure "non-dependent directory is non-empty."
+
+ -- Return the result as a string expression
+ stringE $ dep_str ++ ", " ++ non_dep_str
=====================================
testsuite/tests/th/all.T
=====================================
@@ -214,6 +214,7 @@ test('T5434', [], multimod_compile,
['T5434', '-v0 -Wall ' + config.ghc_th_way_flags])
test('T5508', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_Depends', [only_ways(['normal'])], makefile_test, ['TH_Depends'])
+test('TH_Depends_Dir', [only_ways(['normal']), js_skip], makefile_test, ['TH_Depends_Dir'])
test('T5597', [], multimod_compile, ['T5597', '-v0 ' + config.ghc_th_way_flags])
test('T5665', [], multimod_compile, ['T5665', '-v0 ' + config.ghc_th_way_flags])
test('T5700', [], multimod_compile,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb3bf37612bfd677a90785ca95db6d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/bb3bf37612bfd677a90785ca95db6d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0