- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/dcoutts/capability-yield] 8 commits: Eliminate a use of releaseCapability_ with always_wakeup
by Duncan Coutts (＠dcoutts) 24 Aug '26

24 Aug '26

Duncan Coutts pushed to branch wip/dcoutts/capability-yield at Glasgow Haskell Compiler / GHC Commits: be623efb by Duncan Coutts at 2026-08-20T00:20:01+01:00 Eliminate a use of releaseCapability_ with always_wakeup This one was purely artificial, just due to the unnecessarily strong pre-condition. We can just weaken the precondition. The capability inbox is non-empty so releaseCapability_ will certainly wake up a task for the capability anyway. We are trying to eliminate the always_wakeup parameter entirely since it is a bit of a design wart. - - - - - 5a0f5849 by Duncan Coutts at 2026-08-20T00:21:23+01:00 Eliminate another use of releaseCapability_ with always_wakeup Previusly in schedulePushWork, it checked if there are sparks for the capability and called releaseAndWakeupCapability if there were and releaseCapability if there were none. This is unnecessary: releaseCapability already ensures that a task will be worken if there are sparks available for the capability. This also lets us remove the now unused releaseAndWakeupCapability, eliminating another use of always_wakeup==true. - - - - - 29ed4da7 by Duncan Coutts at 2026-08-24T12:21:45+01:00 Make prodCapability reliable, fix race condition Also eliminate the last use of releaseCapability_ using the always_wakeup param. Add a Note that describes the problem and solution. Now that prodCapability also does an interruptCapability (if the capability is active) then we don't need to use interruptCapability as well at call sites of prodCapability. - - - - - 9a4e2330 by Duncan Coutts at 2026-08-24T12:24:23+01:00 Eliminate the now-unused always_wakeup param from releaseCapability_ releaseCapability_ had an extra bool param: always_wakeup. This was rather a design wart. We have now eliminated all uses of it so we can remove the param entirely. This will also reduce churn at call site when we add a new (rarely used) parameter in the subsequent commit. - - - - - 65241766 by Duncan Coutts at 2026-08-24T12:41:33+01:00 Add releaseCapability_ worker with a wakeup_worker modifier Split releaseCapability_ into a worker and wrapper. The worker gains the extra wakeup_worker parameter. Document within releaseCapability__ the basic approach of looking for a series of conditions in priority order and acting on them. Then add a modifier, wakeup_worker and explain it in similar terms. What it does is skip two of the conditions in the priority list, with the effect that we prioritise waking up a worker task over a returning task or bound task. This feature is not yet used in this commit, but it will be used as part of a scheme to allow in-RTS I/O managers in the threaded RTS. This scheme will make use of being able to start a background worker thread, and that will use this feature to start it promptly. Also correct the yieldCapability docs to cover all the conditions, and in priority order for consistency. - - - - - 3428302b by Duncan Coutts at 2026-08-24T12:45:07+01:00 Move enqueueWorker next to where it is used. It's not general purpose at all. It's very specifically crafted to work with it's only caller: yieldCapability. It does very suprising things like releaseCapability_, release locks and terminate threads. This logic would be much clearer if done within yieldCapability. - - - - - efe433ca by Duncan Coutts at 2026-08-24T12:47:14+01:00 Move code out of enqueueWorker and into releaseCapability_ Instead of directly releasing locks and terminating tasks, have it return whether the enqueue was successful or not. In the latter case, releaseCapability_ itself will release locks and terminate the task. This makes the logic of releaseCapability_ a lot clearer. Fiddling with tasks is what releaseCapability_ does, so it's better not to try and encapsulate this within a helper function. - - - - - e0e3f390 by Duncan Coutts at 2026-08-24T12:47:19+01:00 Clarify the logic and control flow in yieldCapability yieldCapability is unfortunately a bit complicated. This change restructures things slightly but should keep the behaviour the same. Previously after calling releaseCapability_ we had a bunch of alternatives, where in each branch we would use RELEASE_LOCK(cap->lock) and do various things before/after the lock is released. This was a bit hard to follow, or to extend (which we need to do). So now we have unconditional acquire and release of the cap->lock, so it's clear where that happens, with releaseCapability_ in between. Then in between these steps we have the various other pre/post actions. Some before releaseCapability_, some after while holing the lock, and some after having released the lock. We explain this structure in a longer comment, and refer back to the structure from the code. - - - - - 6 changed files: - rts/Capability.c - rts/Capability.h - rts/Messages.c - rts/RtsAPI.c - rts/Schedule.c - rts/sm/GC.c Changes: ===================================== rts/Capability.c ===================================== @@ -560,7 +560,7 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task) #endif /* ---------------------------------------------------------------------------- - * releaseCapability_ + * releaseCapability and releaseCapability_ * * This serves two purposes: * @@ -570,32 +570,37 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task) * * 2. There is no current task (cap->task == NULL), and thus the Capability * is idle, and we want to wake up an idle Task to animate the Capability. - * In this case set always_wakeup. See also prodCapability. + * See also prodCapability. * - * Setting the always_wakeup parameter (almost) ensures that the capability is - * not left idle: even if there is no known work to do, the capability will be - * given to a worker task. There are two exceptions to this: - * 1. if there is a pending sync then the capability is left idle, but in - * anticipation of whichever task initiated the sync picking it up shortly. - * 2. if the scheduler is shutting down and there are no threads on the run - * queue and there are no spare workers then the capability is left idle. - * It is not entirely clear if this corner case is intentional. - * - * The caller must hold cap->lock and will still hold it after the call returns. + * Difference: + * - releaseCapability the caller /must not/ hold cap->lock. + * - releaseCapability_ the caller /must/ hold cap->lock. * * N.B. May need to take all_tasks_mutex, if it needs to start a new task. * * ------------------------------------------------------------------------- */ #if defined(THREADED_RTS) -void -releaseCapability_ (Capability* cap, - bool always_wakeup) +static void releaseCapability__ (Capability* cap, bool wakeup_worker); + +void releaseCapability (Capability* cap) +{ + ACQUIRE_LOCK(&cap->lock); + releaseCapability__(cap, false /*wakeup_worker*/); + RELEASE_LOCK(&cap->lock); +} + +void releaseCapability_ (Capability* cap) +{ + releaseCapability__(cap, false /*wakeup_worker*/); +} + +static void releaseCapability__ (Capability* cap, + bool wakeup_worker) { { Task *task = cap->running_task; - ASSERT(task || always_wakeup); // To cover purpose 2 above, we allow the cap->running_task to be // NULL, to handle cases where a thread (that is not itself a Task) // needs to wake up an idle task for the capability. @@ -609,6 +614,33 @@ releaseCapability_ (Capability* cap, // Remove the current Task owning the Capability (if any, see purpose 2). RELAXED_STORE(&cap->running_task, NULL); + // We now look for a task to give the capability to, or otherwise we leave + // the capability free. + // + // We take one of these guarded actions, in priority order: + // + // 1. If there's a pending synchronisation of all capabilities (e.g. GC), + // then give the capability to the task performing the sync. + // 2. If there's a task returning (e.g. from safe FFI) on this capability, + // then give the capability to the first such task. + // 3. If the next runnable thread on this capability is a bound thread, + // then give the capability to the corresponding bound task. + // 4. If there are no spare worker tasks for this capability, + // then start one and give the capability to the new task. + // 5. If there is some work to do on this capability (e.g. runnable thread), + // then give the capability to a worker task. + // 6. Otherwise leave the capability free/idle. + // + // There is one modifier to this priority list: + // + // * Setting wakeup_worker skips cases 2 & 3. This prioritises waking a + // worker over returning tasks or bound tasks. + + + // Guarded action 1: + // If there's a pending synchronisation of all capabilities (e.g. GC), + // then give the capability to the task performing the sync. + // // If there is a pending sync, the task that requested the sync will // subsequently use acquireAllCapabilities to place itself on the (front of // the) returning_task list (of all capabilities). We will then be in one @@ -656,17 +688,22 @@ releaseCapability_ (Capability* cap, return; } - // Check to see whether a worker thread can be given - // the go-ahead to return the result of an external call.. - if (cap->n_returning_tasks != 0) { + // Skip guarded actions 2 & 3 if wakeup_worker. See the list of actions and + // modifiers above. + + // Guarded action 2: + // If there's a task returning (e.g. from safe FFI) on this capability, + // then give the capability to the first such task. + if (!wakeup_worker && cap->n_returning_tasks != 0) { giveCapabilityToTask(cap,cap->returning_tasks_hd); // The Task pops itself from the queue (see waitForCapability()) return; } - // If the next thread on the run queue is a bound thread, - // give this Capability to the appropriate Task. - if (!emptyRunQueue(cap) && peekRunQueue(cap)->bound) { + // Guarded action 3: + // If the next runnable thread on this capability is a bound thread, + // then give the capability to the bound thread's corresponding task. + if (!wakeup_worker && !emptyRunQueue(cap) && peekRunQueue(cap)->bound) { // Make sure we're not about to try to wake ourselves up // ASSERT(task != cap->run_queue_hd->bound); // assertion is false: in schedule() we force a yield after @@ -677,11 +714,13 @@ releaseCapability_ (Capability* cap, return; } + // Guarded action 4: + // If there are no spare worker tasks for this capability, + // then start one and give the capability to the new task. if (!cap->spare_workers) { - // Create a worker thread if we don't have one. If the system - // is interrupted, we only create a worker task if there - // are threads that need to be completed. If the system is - // shutting down, we never create a new worker. + // If the system is interrupted, we only create a worker task if there + // are threads that need to be completed. If the system is shutting + // down, we never create a new worker. if (getSchedState() < SCHED_SHUTTING_DOWN || !emptyRunQueue(cap)) { debugTrace(DEBUG_sched, "starting new worker on capability %d", cap->no); @@ -690,10 +729,14 @@ releaseCapability_ (Capability* cap, } } - // If we have an unbound thread on the run queue, or if there's - // anything else to do, give the Capability to a worker thread. - if (always_wakeup || - !emptyRunQueue(cap) || !emptyInbox(cap) || + // Guarded action 5: + // If there is some work to do on this capability (e.g. runnable thread), + // then give the capability to a worker task. + // + // We also check the cap->interrupt flag to avoid a race condition. + // See Note [prodCapability reliability]. + // + if (!emptyRunQueue(cap) || !emptyInbox(cap) || cap->interrupt || (!cap->disabled && !emptySparkPoolCap(cap)) || globalWorkToDo()) { if (cap->spare_workers) { giveCapabilityToTask(cap, cap->spare_workers); @@ -702,59 +745,14 @@ releaseCapability_ (Capability* cap, } } + // Guarded action 6: + // Otherwise leave the capability free/idle. #if defined(PROFILING) cap->r.rCCCS = CCS_IDLE; #endif RELAXED_STORE(&last_free_capability[cap->node], cap); debugTrace(DEBUG_sched, "freeing capability %d", cap->no); } - -void -releaseCapability (Capability* cap) -{ - ACQUIRE_LOCK(&cap->lock); - releaseCapability_(cap, false); - RELEASE_LOCK(&cap->lock); -} - -void -releaseAndWakeupCapability (Capability* cap) -{ - ACQUIRE_LOCK(&cap->lock); - releaseCapability_(cap, true); - RELEASE_LOCK(&cap->lock); -} - -static void -enqueueWorker (Capability* cap) -{ - Task *task; - - task = cap->running_task; - - // If the Task is stopped, we shouldn't be yielding, we should - // be just exiting. - ASSERT(!task->stopped); - ASSERT(task->worker); - - if (cap->n_spare_workers < MAX_SPARE_WORKERS) - { - task->next = cap->spare_workers; - cap->spare_workers = task; - cap->n_spare_workers++; - } - else - { - debugTrace(DEBUG_sched, "%d spare workers already, exiting", - cap->n_spare_workers); - releaseCapability_(cap,false); - // hold the lock until after workerTaskStop; c.f. scheduleWorker() - workerTaskStop(task); - RELEASE_LOCK(&cap->lock); - shutdownThread(); - } -} - #endif /* @@ -1051,12 +1049,6 @@ static void waitForCapability_ (Task *task, * when either we know that the Capability should be given to another Task, or * there is nothing to do right now. One of the following is true: * - * - The current Task is a worker, and there's a bound thread at the head of - * the run queue (or vice versa) - * - * - The run queue is empty. We'll be woken up again when there's work to - * do. - * * - Another Task is trying to do parallel GC (pending_sync == SYNC_GC_PAR). * We should become a GC worker for a while. * @@ -1064,12 +1056,21 @@ static void waitForCapability_ (Task *task, * SYNC_GC_PAR), either to do a sequential GC, forkProcess, or * setNumCapabilities. We should give up the Capability temporarily. * + * - There is a Task returning from a safe FFI call. + * + * - The current Task is a worker, and there's a bound thread at the head of + * the run queue (or vice versa) + * + * - There is no work to do (empty run queue, inbox etc). We'll be woken up + * again when there's work to do. + * * When yieldCapability returns *pCap will have been updated to the new * capability held by the caller. * * ------------------------------------------------------------------------- */ #if defined(THREADED_RTS) +static bool tryEnqueueWorker (Capability* cap); /* See Note [GC livelock] in Schedule.c for why we have gcAllowed and return the bool */ @@ -1124,28 +1125,61 @@ yieldCapability // We must now release the capability and wait to be woken up again. task->wakeup = false; + // What happens next is a bit complicated. It has the following outline: + // + // 1. take the cap->lock + // 2. "various stuff part A", pre-releaseCapability_ holding cap->lock + // 3. release the capability + // 4. "various stuff part B", post-releaseCapability_ holding cap->lock + // 5. release the cap->lock + // 6. "various stuff part C", post release cap->lock + // + // Much of the "various stuff" is also conditional, which complicates + // matters further. To try and maintain clarity we use the following + // variables in the conditions for the in-between steps. + // + bool terminate_worker = false; + bool task_is_worker = isWorker(task); + bool task_is_bound = isBoundTask(task); + + // Step 1: take the cap->lock ACQUIRE_LOCK(&cap->lock); - // If this is a worker thread, put it on the spare_workers queue - if (isWorker(task)) { - enqueueWorker(cap); + // Step 2: "various stuff part A", pre-releaseCapability_ holding cap->lock + if (task_is_worker) { + // If this is a worker thread, try to put it on the spare_workers + // queue or if it is surplus then we will terminate it. + terminate_worker = !tryEnqueueWorker(cap); } - releaseCapability_(cap, false); + // Step 3: release the capability + releaseCapability_(cap); - if (isWorker(task) || isBoundTask(task)) { - RELEASE_LOCK(&cap->lock); - cap = waitForWorkerCapability(task); - } else { + // Step 4: "various stuff part B", post-releaseCapability_ holding cap->lock + if (terminate_worker) { + // hold the lock until after workerTaskStop; c.f. scheduleWorker() + workerTaskStop(task); + } else if (!task_is_worker && !task_is_bound) { // Not a worker Task, or a bound Task. The only way we can be woken up // again is to put ourselves on the returning_tasks queue, so that's - // what we do. We still hold cap->lock at this point - // The Task waiting for this Capability does not have it - // yet, so we can be sure to be woken up later. (see #10545) + // what we do. We still hold cap->lock at this point. The Task waiting + // for this Capability does not have it yet, so we can be sure to be + // woken up later. (see #10545) appendToReturningTaskQueue(cap,task); - RELEASE_LOCK(&cap->lock); + } + + // Step 5: release the cap->lock + RELEASE_LOCK(&cap->lock); + + // Step 6. "various stuff part C", post release cap->lock + if (terminate_worker) { + shutdownThread(); + } else if (task_is_worker || task_is_bound) { + cap = waitForWorkerCapability(task); + } else { cap = waitForReturnCapability(task); } + // End of step 6. debugTrace(DEBUG_sched, "resuming capability %d", cap->no); ASSERT(cap->running_task == task); @@ -1161,6 +1195,33 @@ yieldCapability return false; } +// Returns true if it could enqueue, and false if the worker is surplus to +// requirements and should be terminated. +static bool tryEnqueueWorker (Capability* cap) +{ + Task *task = cap->running_task; + + // If the Task is stopped, we shouldn't be yielding, we should + // be just exiting. + ASSERT(!task->stopped); + ASSERT(task->worker); + ASSERT_LOCK_HELD(&cap->lock); + + if (cap->n_spare_workers < MAX_SPARE_WORKERS) + { + task->next = cap->spare_workers; + cap->spare_workers = task; + cap->n_spare_workers++; + return true; + } + else + { + debugTrace(DEBUG_sched, "%d spare workers already, exiting", + cap->n_spare_workers); + return false; + } +} + #endif /* THREADED_RTS */ @@ -1391,8 +1452,40 @@ void releaseAllCapabilities(uint32_t n, Capability *keep_cap, Task *task) /* ---------------------------------------------------------------------------- * prodCapability * - * If a Capability is currently idle, wake up a Task on it. Used to - * get every Capability into the GC. + * If a Capability is currently idle, wake up a Task on it. If it is not idle, + * interrupt it. + * + * Used to get every Capability into the GC. Also used for ctl-C handling + * to get the capability to run the scheduler. + * + * Note [prodCapability reliability] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * + * There's a potential race condition with prodCapability: a task running a + * capability may be just about to yield when it is prodded and then let the + * capability go idle, thus missing the prod. To avoid this we must check if + * the capability has been prodded in a reliable fashion when the task is + * yielding the capability. This is much like the issue of the race between + * sending a capability a message and the capability going idle (where it's + * vital that we don't let a capability go idle if there's a pending message). + * The solution we use is much the same as the solution for messages: rely on + * a shared variable set and tested while holding the cap->lock. + * + * The scheme is as follows: + * 1. Set the cap->interrupt flag in prodCapability while holding the cap->lock + * 2. Test the cap->interrupt flag in releaseCapability_ while holding the + * cap->lock. If the flag is set then make sure to pass the capability to + * a worker task (which often would be the task that was just releasing it). + * 3. Make sure to reset the cap->interrupt flag at the start of the scheduler + * loop. (Historically it was only reset when running a Haskell thread.) + * We must do this before the scheduler yields again or we could loop + * indefinitely. + * + * This scheme ensures that we run the scheduler loop once more, which will + * react to the prod or reset the flag and yield again. In particular for + * getting tasks into GC they will do that in yieldCapability, and for ctl-c + * the scheduler will asks the I/O manager to poll for events which will pick + * up pending signals. * ------------------------------------------------------------------------- */ #if defined(THREADED_RTS) @@ -1401,9 +1494,22 @@ void prodCapability (Capability *cap) { ACQUIRE_LOCK(&cap->lock); - if (!cap->running_task) { - releaseCapability_(cap,true); + if (cap->running_task) { + /* Set the cap->interrupt so that the capability will not go idle + * before attending to the reason for the interrupt. + * See Note [prodCapability reliability]. + */ + interruptCapability(cap); + } else { + /* Set the cap->interrupt first so that releaseCapability_ will see + * that there is something to do on this capability and ensure the + * cap is given to a task. See Note [prodCapability reliability]. + */ + interruptCapability(cap); + releaseCapability_(cap); } + /* Notice that we use interruptCapability either way, but for different + * reasons */ RELEASE_LOCK(&cap->lock); } @@ -1523,7 +1629,7 @@ shutdownCapability (Capability *cap USED_IF_THREADS, if (!emptyRunQueue(cap) || cap->spare_workers) { debugTrace(DEBUG_sched, "runnable threads or workers still alive, yielding"); - releaseCapability_(cap,false); // this will wake up a worker + releaseCapability_(cap); // this will wake up a worker RELEASE_LOCK(&cap->lock); yieldThread(); continue; ===================================== rts/Capability.h ===================================== @@ -262,16 +262,13 @@ void moreCapabilities (uint32_t from, uint32_t to); // ASSUMES: cap->running_task is the current Task. // #if defined(THREADED_RTS) -void releaseCapability (Capability* cap); -void releaseAndWakeupCapability (Capability* cap); -void releaseCapability_ (Capability* cap, bool always_wakeup); +void releaseCapability (Capability* cap); +void releaseCapability_ (Capability* cap); // assumes cap->lock is held #else // releaseCapability() is empty in non-threaded RTS INLINE_HEADER void releaseCapability (Capability* cap STG_UNUSED) {}; -INLINE_HEADER void releaseAndWakeupCapability (Capability* cap STG_UNUSED) {}; -INLINE_HEADER void releaseCapability_ (Capability* cap STG_UNUSED, - bool always_wakeup STG_UNUSED) {}; +INLINE_HEADER void releaseCapability_ (Capability* cap STG_UNUSED) {}; #endif // declared in rts/include/rts/Threads.h: ===================================== rts/Messages.c ===================================== @@ -49,11 +49,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) recordClosureMutated(from_cap,(StgClosure*)msg); if (to_cap->running_task == NULL) { - /* Precond for releaseCapability_ is: running_task || always_wakeup. - * We have running_task == NULL, hence we must use always_wakeup. This - * is ok since the inbox is now non-empty, so we wake a task anyway. - */ - releaseCapability_(to_cap, true /*always_wakeup*/); + releaseCapability_(to_cap); } else { interruptCapability(to_cap); } ===================================== rts/RtsAPI.c ===================================== @@ -691,7 +691,7 @@ rts_unlock (Capability *cap) // random point in the future, which causes problems for // freeTaskManager(). ACQUIRE_LOCK(&cap->lock); - releaseCapability_(cap,false); + releaseCapability_(cap); // Finally, we can release the Task to the free list. exitMyTask(); ===================================== rts/Schedule.c ===================================== @@ -283,6 +283,10 @@ schedule (Capability *initialCapability, Task *task) barf("sched_state: %" FMT_Word, sched_state); } + // Reset the interrupt flag upon starting the scheduler loop. + // See Note [prodCapability reliability]. + RELAXED_STORE(&cap->interrupt, false); + scheduleFindWork(&cap); /* work pushing, currently relevant only for THREADED_RTS: @@ -430,9 +434,6 @@ run_thread: SetLastError(t->saved_winerror); #endif - // reset the interrupt flag before running Haskell code - RELAXED_STORE(&cap->interrupt, false); - cap->in_haskell = true; RELAXED_STORE(&cap->idle, false); @@ -837,13 +838,9 @@ schedulePushWork(Capability *cap USED_IF_THREADS, // release the capabilities for (i = 0; i < n_free_caps; i++) { task->cap = free_caps[i]; - if (sparkPoolSizeCap(cap) > 0) { - // If we have sparks to steal, wake up a worker on the - // capability, even if it has no threads to run. - releaseAndWakeupCapability(free_caps[i]); - } else { - releaseCapability(free_caps[i]); - } + // If there are sparks available, this will wake up a Task to run + // the Capability, even if it has no threads to run. + releaseCapability(free_caps[i]); } } task->cap = cap; // reset to point to our Capability. @@ -1905,7 +1902,7 @@ forkProcess(HsStablePtr *entry #endif for (i=0; i < n_capabilities; i++) { - releaseCapability_(getCapability(i),false); + releaseCapability_(getCapability(i)); RELEASE_LOCK(&getCapability(i)->lock); } @@ -2320,7 +2317,7 @@ suspendThread (StgRegTable *reg, bool interruptible) suspendTask(cap,task); cap->in_haskell = false; - releaseCapability_(cap,false); + releaseCapability_(cap); RELEASE_LOCK(&cap->lock); @@ -2513,7 +2510,7 @@ void scheduleWorker (Capability *cap, Task *task) // Capability has been shut down. // ACQUIRE_LOCK(&cap->lock); - releaseCapability_(cap,false); + releaseCapability_(cap); workerTaskStop(task); RELEASE_LOCK(&cap->lock); } ===================================== rts/sm/GC.c ===================================== @@ -1523,7 +1523,6 @@ waitForGcThreads (Capability *cap, bool idle_cap[]) if (i == me || idle_cap[i]) { continue; } if (SEQ_CST_LOAD(&gc_threads[i]->wakeup) != GC_THREAD_STANDING_BY) { prodCapability(getCapability(i)); - interruptCapability(getCapability(i)); } } // this 1ms timeout is not well justified. It's the shortest timeout we View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9cfe2ee2cb65cc5d63ce6dbc978929… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9cfe2ee2cb65cc5d63ce6dbc978929… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 6e4d44f0 by Andreas Klebinger at 2026-08-24T06:35:03-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - f4a97277 by Alan Zimmerman at 2026-08-24T06:35:03-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/16b7cd2276cabc9df326d4a6aa6895… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/16b7cd2276cabc9df326d4a6aa6895… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 3d44d11a by Andreas Klebinger at 2026-08-24T06:14:30-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 16b7cd22 by Alan Zimmerman at 2026-08-24T06:14:31-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e4eb741cd5a14d45f6751ad442de1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7e4eb741cd5a14d45f6751ad442de1… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/sjakobi/T27628-rebox-warning] 14 commits: SpecConstr: Don't warn about reboxing nullary constructors
by Simon Jakobi (＠sjakobi) 24 Aug '26

24 Aug '26

Simon Jakobi pushed to branch wip/sjakobi/T27628-rebox-warning at Glasgow Haskell Compiler / GHC Commits: 903a0046 by Simon Jakobi at 2026-08-22T14:12:01+02:00 SpecConstr: Don't warn about reboxing nullary constructors "Reboxing" a nullary constructor just references its shared static closure: it costs no allocation and even preserves pointer identity. Such patterns are common (Nil, [], Nothing, ...) and accounted for a fair share of the -Wspec-constr-reboxing warnings when compiling containers, e.g. from functions matching an empty-set argument. See Note [Reboxing warning]. Assisted-by: Claude Fable 5 - - - - - 523a633a by Simon Jakobi at 2026-08-22T14:17:27+02:00 SpecConstr: Attribute reboxing warnings to the enclosing binder -Wspec-constr-reboxing frequently fires on local functions — join points and local workers — whose names are meaningless to the user and which often have no source location at all, e.g. $j_sahl (Present) Defined at <no location info> Track the enclosing top-level binder in ScEnv (sc_top_fn) and name it in the warning, pointing at its definition site: that is where any remedy would be applied. See Note [Reboxing warning]. Assisted-by: Claude Fable 5 - - - - - 16f32940 by Simon Jakobi at 2026-08-22T14:25:01+02:00 SpecConstr: Emit one reboxing warning per function Emit -Wspec-constr-reboxing as one diagnostic per specialised function, merging the reboxed constructors of all its call patterns, instead of a single module-wide list. Compiling containers produced several near-identical entries per function (one per call pattern), e.g. four times `$wgo (Collision)`. The shorter per-function message points at the users guide for the possible remedies instead of spelling them out each time. Also: document the nullary-constructor exemption and the attribution of local functions in the users guide. Assisted-by: Claude Fable 5 - - - - - b01adcd0 by Simon Jakobi at 2026-08-22T14:28:11+02:00 SpecConstr: Merge reboxing warnings that would render identically Distinct local functions frequently share an occurrence name and enclosing binder (e.g. two workers both called merge0 inside IntMap.unionWithKey, from different unfoldings of the same source function), producing warnings that differ only in their Name's unique and so print as exact duplicates. Key the per-function aggregation on (occurrence name, parent) instead of the Name. Assisted-by: Claude Fable 5 - - - - - 96b4e968 by Simon Jakobi at 2026-08-22T15:08:14+02:00 SetLevels: Preserve source spans on floated poly_ bindings When the float-out pass lifts a local function past type-variable bindings, newPolyBndrs made the new poly_ binder with mkSysLocal, dropping the original binder's source span. Diagnostics naming such bindings — e.g. -Wspec-constr-reboxing (#27628) — could then only report "defined at <no location info>". Keep the original span on the poly_ binder instead. Worker/wrapper derives worker names with mkDerivedInternalName, so $wpoly_ bindings inherit the span for free. The new test T27628g checks that a reboxing warning about a floated local function points at its definition site. Assisted-by: Claude Fable 5 - - - - - c2318213 by Simon Jakobi at 2026-08-22T15:24:25+02:00 SpecConstr: Point reboxing warnings at the local function's definition A reboxing warning about a local function showed the enclosing top-level binder's location, so distinct same-named locals rendered identically and were merged into one warning. Applying a remedy to one of them then left the warning seemingly unchanged, with no hint that progress had been made. Show the local function's own definition site instead, falling back to the parent's only when the local has none (e.g. simplifier-made join points). Merging now only affects warnings that point at the same site, which a single source-level remedy addresses together; see Note [Reboxing warning]. Assisted-by: Claude Fable 5 - - - - - 35025093 by Simon Jakobi at 2026-08-23T04:14:09+02:00 SpecConstr: Explain reboxing warnings that have no source location A stage-2 GHC build showed 387 of 499 reboxing warnings pointing at "<no location info>": local loops (e.g. foldr's go, Data.Map's fromList stack machinery) that reach the consuming module in interface unfoldings, which record no spans for local binders. Rendering an unhelpful span reads like a bug and gives the user nothing to act on. Instead say "inlined from another module; no source location", and show constructors imported from other modules qualified with their defining module — with the function anonymous, they are what identifies the package to report the reboxing to. Also quote the function, parent, and constructor names, matching the usual diagnostic style. See the new bullet in Note [Reboxing warning]. Context: #27628. Assisted-by: Claude Fable 5 - - - - - 92115070 by Simon Jakobi at 2026-08-23T04:22:42+02:00 SpecConstr: Merge indistinguishable reboxing warnings uniformly Reboxing warnings that would render identically were merged only when a parent attribution was present. Parentless warnings were compared by Name instead. For located top-level functions the two rules agree, since distinct functions differ in name or location, but span-less loops from imported unfoldings all render as e.g. SpecConstr specialised 'go1' (inlined from another module; ...) and were still printed once per copy: a stage-2 GHC build had 67 such go1 lines, 10 of them in a single module. The reader cannot tell the copies apart, and none of them can be located, so repetition carries no information. Drop the special case and merge on render identity throughout, combining the constructor lists of merged warnings. New test T27628i checks that two span-less same-named loops produce a single warning listing both reboxed constructors. Context: #27628. Assisted-by: Claude Fable 5 - - - - - 47e5dc94 by Simon Jakobi at 2026-08-23T13:34:21+02:00 SpecConstr: Show the specialised function's type in reboxing warnings A reboxing warning about a span-less loop inlined from another module identifies it only by a meaningless name like go1. The type is usually short and is the best available clue to what the function does, so print it after the name. The type also joins the render-identity merge key, so same-named span-less loops of different types no longer collapse into one warning. See Note [Reboxing warning]. T27628i gains a third source function whose loop matches the first one's rendering, keeping the merge of indistinguishable warnings exercised. Context: #27628. Assisted-by: Claude Fable 5 - - - - - 8d2e130b by Simon Jakobi at 2026-08-23T13:39:46+02:00 SpecConstr: Name the calling functions in span-less reboxing warnings A reboxing warning about a function inlined from another module can point at no located code at all. The call sites that drove the specialisation can: they sit in top-level binders of the module being compiled, and following the inlining from one of them identifies the reboxed loop. Record the enclosing top-level binder of each call (sc_top_fn) in Call, thread it through CallPat, and render it as "called from". See Note [Reboxing warning]. Context: #27628. Assisted-by: Claude Fable 5 - - - - - c817c224 by Simon Jakobi at 2026-08-23T23:06:52+02:00 Render the reboxing warning as a labelled fact block The prose rendering packed definition site, callers, and constructors into one parenthesised run-on that grew hard to scan, especially with several callers or constructors. Instead show one labelled fact per line (source, called from, reboxed constructors), values aligned, with the wrapped-up prose reduced to a closing sentence whose grammar tracks the constructor count. The printed forall is suppressed (pprSigmaType) and callers are now always shown, including the enclosing binder of a local function: as a separate labelled fact it no longer reads as a duplicate of the source line. Since the constructor list is now part of what the reader sees per warning, it joins the render-identical merge key. Same-function warnings still merge unconditionally, in a separate pass keyed on the function's Name. Part of #27628. Assisted-by: Claude Fable 5 - - - - - bbc2f3f9 by Simon Jakobi at 2026-08-23T23:14:48+02:00 Classify the specialised function's recursivity in reboxing warnings A "recursivity:" fact says whether the function SpecConstr specialised is self-recursive, mutually recursive (naming the other functions of its Rec group), or non-recursive (e.g. a join point), as bound in the post-optimisation program. Where the warning fires on code the reader never wrote in that shape — floated-out loops, span-less inlined copies — this narrows down what to look for at the source. The classification falls out of the specialisation entry points: specRec knows the Rec group (a singleton is genuinely self-recursive, since the occurrence analyser demotes non-recursive singletons to NonRec), and specNonRec handles nested non-recursive bindings. See Note [Reboxing warning]. Part of #27628. Assisted-by: Claude Fable 5 - - - - - f0337cb7 by Simon Jakobi at 2026-08-24T01:51:48+02:00 Show the call patterns in reboxing warnings A reboxing warning used to list the reboxed constructors of all the function's specialisations as one flat set, which erased the structure that makes such a list intelligible: constructors from alternative patterns of one argument, and constructors nested inside others, read as an unrelated jumble. Now each call pattern is shown as the constructor skeletons of its arguments, e.g. call patterns: go (A _) (I# _) (reboxing ‘A’) go (B _) (I# _) (reboxing ‘B’) which also pictures what SpecConstr did: it copied the function for calls of exactly that shape. See Note [Reboxing warning]. Also fix the per-function aggregation, which keyed on the function's Name alone: two top-level bindings can bind distinct locals sharing a unique (copies of one inlined unfolding template), and their warnings were fused, dropping one warning's type and doubling the callers. The key now includes the enclosing top-level binder. T27628l pins the fixed behaviour with the Max/Min pair that exposed this. Part of #27628. Assisted-by: Claude Fable 5 - - - - - 147702b0 by Simon Jakobi at 2026-08-24T02:54:10+02:00 Render the reboxing tag as a comment, not parens Parenthesized as (reboxing 'A'), the tag read as one more argument of the call pattern. A comment can't be part of a call, and GHC already annotates output this way (:info's "-- Defined in"): call patterns: go (A _) (I# _) -- reboxes 'A' go (B _) (I# _) -- reboxes 'B' Part of #27628. Assisted-by: Claude Fable 5 - - - - - 23 changed files: - compiler/GHC/Core/Opt/SetLevels.hs - compiler/GHC/Core/Opt/SpecConstr.hs - docs/users_guide/using-warnings.rst - testsuite/tests/simplCore/should_compile/T27628.stderr - testsuite/tests/simplCore/should_compile/T27628b.stderr - + testsuite/tests/simplCore/should_compile/T27628e.hs - + testsuite/tests/simplCore/should_compile/T27628f.hs - + testsuite/tests/simplCore/should_compile/T27628f.stderr - + testsuite/tests/simplCore/should_compile/T27628g.hs - + testsuite/tests/simplCore/should_compile/T27628g.stderr - + testsuite/tests/simplCore/should_compile/T27628h.hs - + testsuite/tests/simplCore/should_compile/T27628h.stderr - + testsuite/tests/simplCore/should_compile/T27628h_M.hs - + testsuite/tests/simplCore/should_compile/T27628i.hs - + testsuite/tests/simplCore/should_compile/T27628i.stderr - + testsuite/tests/simplCore/should_compile/T27628i_M.hs - + testsuite/tests/simplCore/should_compile/T27628j.hs - + testsuite/tests/simplCore/should_compile/T27628j.stderr - + testsuite/tests/simplCore/should_compile/T27628k.hs - + testsuite/tests/simplCore/should_compile/T27628k.stderr - + testsuite/tests/simplCore/should_compile/T27628l.hs - + testsuite/tests/simplCore/should_compile/T27628l.stderr - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Opt/SetLevels.hs ===================================== @@ -108,8 +108,8 @@ import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) -import GHC.Types.Name ( getOccName ) -import GHC.Types.Name.Occurrence ( occNameFS ) +import GHC.Types.Name ( getOccName, getSrcSpan, mkSystemNameAt ) +import GHC.Types.Name.Occurrence ( occNameFS, mkVarOccFS ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply @@ -1872,7 +1872,10 @@ newPolyBndrs dest_lvl mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id transfer_join_info bndr $ - mkSysLocal str uniq (idMult bndr) poly_ty + -- Keep bndr's srcspan so that diagnostics can + -- still point at the original definition + mkLocalId (mkSystemNameAt uniq (mkVarOccFS str) (getSrcSpan bndr)) + (idMult bndr) poly_ty where str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr) poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr)) ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -36,6 +36,9 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Predicate ( scopedSort, typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) +import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.TyCo.Ppr ( pprSigmaType ) +import GHC.Core.TyCo.Tidy ( tidyTopType ) import GHC.Core.TyCon (TyCon, tyConName ) import GHC.Core.Multiplicity import GHC.Core.Ppr ( pprParendExpr ) @@ -45,12 +48,13 @@ import GHC.Unit.Module.ModGuts import GHC.Types.InlinePragma import GHC.Types.Error (DiagnosticReason(..)) -import GHC.Types.Literal ( litIsLifted ) +import GHC.Types.Literal ( Literal, litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name +import GHC.Types.SrcLoc ( isGoodSrcSpan ) import GHC.Types.Tickish import GHC.Types.Basic import GHC.Types.Demand @@ -75,7 +79,7 @@ import GHC.Exts( SpecConstrAnnotation(..) ) import GHC.Serialized ( deserializeWithData ) import Control.Monad -import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL, nub, unzip4 ) +import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL, nub, nubBy, unzip4 ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) @@ -790,8 +794,8 @@ specConstrProgram guts is_rebox _ = False ; when (not (null forced_ws)) $ diagnostic WarningWithoutFlag (forced_msg forced_ws) - ; when (not (null rebox_ws)) $ diagnostic (WarningWithFlag Opt_WarnSpecConstrReboxing) - (rebox_msg (nub rebox_ws)) + ; mapM_ (diagnostic (WarningWithFlag Opt_WarnSpecConstrReboxing) . rebox_msg) + (aggregateRebox rebox_ws) ; return (guts { mg_binds = binds' }) } @@ -802,15 +806,137 @@ specConstrProgram guts nest 2 (vcat (map ppr warnings)) $$ (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.") + -- One warning per specialised function (all its patterns listed), + -- then warnings that would render identically merged too; see + -- Note [Reboxing warning] + aggregateRebox :: SpecConstrWarnings -> SpecConstrWarnings + aggregateRebox = mergeBy same_render . mergeBy same_fn + where + mergeBy eq ws + = [ SpecReboxed fn ty parent recur (nubBy same_pat (concat patss)) (nub (concat callerss)) + | w@(SpecReboxed fn ty parent recur _ _) <- nubBy eq ws + , let (patss, callerss) = unzip [ (pats, callers) + | w'@(SpecReboxed _ _ _ _ pats callers) <- ws + , eq w w' ] ] + + -- Also compare the parents: the fn Name alone is ambiguous + -- between top-level bindings; see Note [Reboxing warning] + same_fn (SpecReboxed fn1 _ p1 _ _ _) (SpecReboxed fn2 _ p2 _ _ _) + = fn1 == fn2 && p1 == p2 + same_fn _ _ = False + + -- Merge warnings that would render identically: same occurrence + -- name, type, parent, displayed location, recursivity, and + -- patterns. The reader could not tell them apart, so printing + -- both is noise; see Note [Reboxing warning]. Callers are + -- aggregated, not compared. + same_render (SpecReboxed fn1 ty1 p1 r1 pats1 _) (SpecReboxed fn2 ty2 p2 r2 pats2 _) + = getOccName fn1 == getOccName fn2 && p1 == p2 + && nameSrcSpan (rebox_loc_name fn1 p1) == nameSrcSpan (rebox_loc_name fn2 p2) + && ty1 `eqType` ty2 + && r1 `same_recur` r2 + && equalLength pats1 pats2 + && and (zipWith same_pat (sortBy cmpReboxedPat pats1) + (sortBy cmpReboxedPat pats2)) + same_render _ _ = False + + same_pat p1 p2 = cmpReboxedPat p1 p2 == EQ + + -- Recursivity as displayed: siblings compare by occurrence name, + -- so span-less copies of one mutual group still merge + same_recur ReboxSelfRec ReboxSelfRec = True + same_recur (ReboxNonRec j1) (ReboxNonRec j2) = j1 == j2 + same_recur (ReboxMutualRec s1) (ReboxMutualRec s2) + = map getOccName (sortBy stableNameCmp s1) + == map getOccName (sortBy stableNameCmp s2) + same_recur _ _ = False + + -- The definition site shown in a reboxing warning: the fn's own when + -- known, otherwise the parent's (e.g. for simplifier-made join points) + rebox_loc_name :: Name -> Maybe Name -> Name + rebox_loc_name fn (Just parent) + | not (isGoodSrcSpan (nameSrcSpan fn)) = parent + rebox_loc_name fn _ = fn + -- See Note [Reboxing warning] - rebox_msg :: SpecConstrWarnings -> SDoc - rebox_msg warnings = text "SpecConstr specialised the following function(s) on a constructor argument that is also used boxed:" $$ - nest 2 (vcat (map ppr warnings)) $$ - text "The specialised code allocates a fresh constructor at each such use (\"reboxing\")," $$ - text "which can increase allocation and defeat pointer-equality-based sharing." $$ - text "Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma," $$ - text "hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy," $$ - text "or use -fno-spec-constr." + rebox_msg :: SpecConstrWarning -> SDoc + rebox_msg w@(SpecFailForcedArgCount {}) = pprPanic "rebox_msg" (ppr w) + rebox_msg (SpecReboxed fn ty mb_parent recur pats callers) + = vcat [ hang (text "SpecConstr specialised") 2 + (quotes (ppr fn <+> dcolon <+> pp_ty)) + , nest 2 $ vcat $ catMaybes + [ Just (fact "source:" pp_source) + , Just (fact "recursivity:" pp_recur) + , fact "called from:" <$> pp_callers + , Just (fact pats_label pp_pats) ] + , pp_trailer + , text "See -Wspec-constr-reboxing in the users guide for possible remedies." ] + where + -- Aligned label column; $$ overlaps, so a multi-line value keeps + -- its lines aligned under the first + fact l v = text l $$ nest 23 v + + -- Truncate only pathologically large types + pp_ty = sdocWithContext $ \ctx -> + case splitAt 10000 (showSDocOneLine ctx pp_tidy) of + (_, []) -> pp_tidy + (prefix, _) -> text prefix <> text "..." + where pp_tidy = pprSigmaType (tidyTopType ty) + -- pprSigmaType: suppress the printed forall + + -- A name with no source span reached this module in an interface + -- unfolding: iface files record no spans for local binders + pp_source = case (mb_parent, isGoodSrcSpan (nameSrcSpan loc_name)) of + (Nothing, True) -> pp_loc + (Just p, True) -> quotes (ppr p) <+> text "at" <+> pp_loc + (Just p, False) -> quotes (ppr p) <> comma <+> pp_no_loc + (Nothing, False) -> pp_no_loc + where + loc_name = rebox_loc_name fn mb_parent + pp_loc = ppr (nameSrcLoc loc_name) + pp_no_loc = text "inlined from another module (no source location)" + + pp_recur = case recur of + ReboxSelfRec -> text "self-recursive" + ReboxNonRec True -> text "non-recursive (a join point)" + ReboxNonRec False -> text "non-recursive" + ReboxMutualRec sibs + -> text "mutually recursive with" + <+> pprWithCommas (quotes . ppr) named <> pp_rest + where + (named, rest) = splitAt 3 (sortBy stableNameCmp sibs) + pp_rest = case length rest of + 0 -> empty + 1 -> text " and 1 other" + n -> text " and" <+> int n <+> text "others" + + pp_callers = case sortBy stableNameCmp callers of + [] -> Nothing + cs -> Just (pprWithCommas (quotes . ppr) cs) + + pats_label = case pats of + [_] -> "call pattern:" + _ -> "call patterns:" + + pp_pats = vcat (map pp_pat (sortBy cmpReboxedPat pats)) + + pp_pat (ReboxedPat shapes cons) + = hang (hang (ppr fn) 2 (fsep (map pprPatShape shapes))) 2 + (text "-- reboxes" <+> + pprWithCommas pp_con (sortBy stableNameCmp cons)) + + -- Qualify imported constructors: they identify the package to + -- follow up with when the function itself has no location + pp_con con + | Just m <- nameModule_maybe con, m /= mg_module guts + = quotes (ppr m <> dot <> ppr con) + | otherwise = quotes (ppr con) + + all_cons = nub [ con | ReboxedPat _ cons <- pats, con <- cons ] + + pp_trailer = fsep $ map text $ words $ case all_cons of + [_] -> "This constructor argument is also used boxed, so the specialisation may increase allocation and defeat pointer-equality-based sharing." + _ -> "These constructor arguments are also used boxed, so the specialisations may increase allocation and defeat pointer-equality-based sharing." scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecConstrWarning]) scTopBinds _env [] = return (nullUsage, [], []) scTopBinds env (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $ @@ -975,7 +1101,12 @@ data ScEnv = SCE { sc_opts :: !SpecConstrOpts, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) - sc_annotations :: UniqFM Name SpecConstrAnnotation + sc_annotations :: UniqFM Name SpecConstrAnnotation, + + sc_top_fn :: Maybe Name + -- The top-level binder whose RHS we are inside, + -- used to attribute warnings about local functions + -- See Note [Reboxing warning] } --------------------- @@ -1025,7 +1156,8 @@ initScEnv guts sc_subst = init_subst, sc_how_bound = emptyVarEnv, sc_vals = emptyVarEnv, - sc_annotations = anns }) } + sc_annotations = anns, + sc_top_fn = Nothing }) } where init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts) -- Acccount for top-level bindings that are not in dependency order; @@ -1046,6 +1178,11 @@ instance Outputable HowBound where scForce :: ScEnv -> Bool -> ScEnv scForce env b = env { sc_force = b } +-- Keeps the outermost binder; see Note [Reboxing warning] +setTopFn :: ScEnv -> OutId -> ScEnv +setTopFn env@(SCE { sc_top_fn = Nothing }) bndr = env { sc_top_fn = Just (idName bndr) } +setTopFn env _ = env + lookupHowBound :: ScEnv -> OutId -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id @@ -1286,9 +1423,11 @@ data ScUsage } -- The domain is OutIds type CallEnv = IdEnv [Call] -- Domain is OutIds -data Call = Call OutId [CoreArg] ValueEnv +data Call = Call OutId [CoreArg] ValueEnv (Maybe Name) -- The arguments of the call, together with the -- env giving the constructor bindings at the call site + -- and the enclosing top-level binder of the call site + -- (sc_top_fn, for reboxing warnings) -- We keep the function mainly for debug output -- -- The call is not necessarily saturated; we just put @@ -1300,7 +1439,7 @@ instance Outputable ScUsage where , text "occs =" <+> ppr occs ]) instance Outputable Call where - ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args) + ppr (Call fn args _ _) = ppr fn <+> fsep (map pprParendExpr args) nullUsage :: ScUsage nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv } @@ -1443,6 +1582,73 @@ that decision bites, without changing which specialisations are made: SpecReboxed warnings, which specConstrProgram emits under -Wspec-constr-reboxing (off by default). +* One warning per function, listing each call pattern the function was + specialised for — the constructor skeletons of the call's arguments, + e.g. `go (_ : _) (BMap _) -- reboxes ‘BMap’` — alongside that + pattern's reboxed constructors. The shapes show where in the + argument each reboxed constructor sits, and picture what SpecConstr + did: it made a copy of + the function for calls of exactly that shape. The warning also shows + the function's type: names like `go1` say nothing, and for span-less + functions (last bullet below) the type is the main identifying clue. + + "Per function" means per (parent, function) *pair*: the function's + Name alone is ambiguous, because distinct top-level bindings can bind + distinct locals that share a unique. That happens when several + bindings inline one stable unfolding (e.g. a class's default-method + template): each copy keeps the template's uniques, and the simplifier + only freshens a binder on an in-scope clash, which cannot arise + between sibling top-level RHSs. + + Warnings that would render identically — same name, type, parent, + definition site, recursivity, and patterns — are merged too: the + reader could not tell them apart, so printing both is noise. For + located functions the merged warnings are simplifier-made copies of one + binding, addressed by a single source-level remedy; span-less loops + inlined from other modules can in principle merge across different + origins, but sharing name and type they are almost certainly copies of + one function. + +* The warning classifies how the specialised function recurses + ("recursivity"), taken from the binding SpecConstr saw: a Rec group of + one is self-recursive (the occurrence analyser demotes non-recursive + singletons to NonRec), a larger group is mutually recursive and the + siblings are named, and a nested NonRec binding — typically a join + point, see Note [Specialising local let bindings] — is non-recursive. + This reflects the post-optimisation program, whose shape can differ + from the source's. + +* Nullary constructors are exempt: "reboxing" a nullary constructor just + references its shared static closure, so it costs no allocation and even + preserves pointer identity. Such patterns are common (Nil, [], Nothing, + ...) and warning about them would be pure noise. + +* Warnings about local functions (join points, local workers) name the + enclosing top-level binder too: locals often have meaningless names, + and any remedy is applied at the enclosing function anyway. + sc_top_fn tracks that binder, set when entering a top-level RHS (or a + specialised copy of one) and kept unchanged below that. The location + shown is the local's own definition site, so same-named locals can be + told apart; only when that is missing (e.g. for simplifier-made join + points) does the warning fall back to the parent's location. + +* The warning lists the top-level binders containing the specialised + calls ("called from"); each Call records the sc_top_fn of its call + site for this purpose. Self-calls of a top-level loop are dropped as + uninformative (in callToPat); a *local* loop's self-calls record its + parent, indistinguishable from the parent's entry call, so the parent + appears among the callers. + +* A function with no source span and no parent reached this module in an + interface unfolding: iface files record no spans for local binders, and + such loops typically float to top level in the consuming module. The + warning says "inlined from another module" instead of showing an + unhelpful span. Imported constructors are shown qualified — with the + function anonymous, they are what identifies the package to report the + reboxing to. For such a warning the call sites ("called from") are the + only located code to point at: following the inlining from one of them + identifies the reboxed loop. + Why BoxPassAlong does not warn: if the callee is specialised at that argument position, its RULE rewrites the constructor-shaped call in the specialised body and no box is ever rebuilt. That is exactly the good case that @@ -1534,7 +1740,7 @@ scBind top_lvl env (NonRec bndr rhs) do_body -- -- I tried always specialising non-recursive top-level bindings too, -- but found some regressions (see !8135). So I backed off. - = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs + = do { (rhs_usage, rhs', ws_rhs) <- scExpr (setTopFn env bndr) rhs -- At top level, we've already put all binders into scope; see initScEnv -- Hence no need to call `extendBndr`. But we still want to @@ -1554,7 +1760,8 @@ scBind top_lvl env (Rec prs) do_body -- why it only applies at top level. But that's the way it has been -- for a while. See #21456. do { (body_usg, body', warnings_body) <- do_body rhs_env2 - ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss + ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (\(b,r) -> scExpr (setTopFn env b) r) + (bndrs' `zip` rhss) ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg) `delCallsFor` bndrs' bind' = Rec (bndrs' `zip` rhss') @@ -1799,7 +2006,7 @@ markPassAlongArg _env _other usg = usg mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage mkVarUsage env fn args = case lookupHowBound env fn of - Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)] + Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env) (sc_top_fn env)] , scu_occs = emptyVarEnv } Just RecArg -> SCU { scu_calls = emptyVarEnv , scu_occs = unitVarEnv fn arg_occ } @@ -1812,7 +2019,7 @@ mkVarUsage env fn args scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecConstrWarnings) scRecRhs env (bndr,rhs) = do { let (arg_bndrs,body) = collectBinders rhs - (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs + (body_env, arg_bndrs') = extendBndrsWith RecArg (setTopFn env bndr) arg_bndrs ; (body_usg, body', body_ws) <- scExpr body_env body ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' ; return (RI { ri_rhs_usg = rhs_usg @@ -1891,7 +2098,9 @@ specNonRec :: ScEnv -- plus details of specialisations specNonRec env body_calls rhs_info - = specialise env body_calls rhs_info (initSpecInfo rhs_info) + = specialise env recur body_calls rhs_info (initSpecInfo rhs_info) + where + recur = ReboxNonRec (isJoinId (ri_fn rhs_info)) ---------------------- specRec :: ScEnv @@ -1911,6 +2120,13 @@ specRec env body_calls rhs_infos where opts = sc_opts env + -- A Rec group of one is genuinely self-recursive: the occurrence + -- analyser demotes non-recursive singletons to NonRec + recur ri = case rhs_infos of + [_] -> ReboxSelfRec + _ -> ReboxMutualRec [ idName (ri_fn ri') | ri' <- rhs_infos + , ri_fn ri' /= ri_fn ri ] + -- Loop, specialising, until you get no new specialisations go, go_again :: Int -- Which iteration of the "until no new specialisations" -- loop we are on; first iteration is 1 @@ -1925,7 +2141,8 @@ specRec env body_calls rhs_infos -- , text "iteration" <+> int n_iter -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) -- ]) $ - do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos + do { specs_w_usg <- zipWithM (\ri si -> specialise env (recur ri) seed_calls ri si) + rhs_infos spec_infos ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg extra_usg = combineUsages extra_usg_s @@ -1963,6 +2180,7 @@ specRec env body_calls rhs_infos ---------------------- specialise :: ScEnv + -> ReboxRecursivity -- How the function recurses, for warnings -> CallEnv -- Info on newly-discovered calls to this function -> RhsInfo -> SpecInfo -- Original RHS plus patterns dealt with @@ -1977,8 +2195,8 @@ specialise -- So when we make a specialised copy of the RHS, we're starting -- from an RHS whose nested functions have been optimised already. -specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs - , ri_lam_body = body, ri_arg_occs = arg_occs }) +specialise env recur bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs + , ri_lam_body = body, ri_arg_occs = arg_occs }) spec_info@(SI { si_specs = specs, si_n_specs = spec_count , si_mb_unspec = mb_unspec }) | isDeadEndId fn -- Note [Do not specialise diverging functions] @@ -2001,7 +2219,9 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs ; let n_pats = length new_pats -- Warn about committed specialisations that will rebox; -- see Note [Reboxing warning] - rebox_ws = [ SpecReboxed (idName fn) (cp_rebox p) + rebox_ws = [ SpecReboxed (idName fn) (idType fn) (sc_top_fn env) + recur [ReboxedPat (patShapes p) (cp_rebox p)] + (cp_callers p) | p <- new_pats, not (null (cp_rebox p)) ] -- ; when (not (null new_pats) || isJust mb_unspec) $ -- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" @@ -2013,7 +2233,9 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs -- , text "arg_occs" <+> ppr arg_occs -- , text "new_pats" <+> ppr new_pats]) - ; let spec_env = decreaseSpecCount env n_pats + ; let spec_env = setTopFn (decreaseSpecCount env n_pats) fn + -- setTopFn: attribute warnings from re-analysing the + -- specialised copies of a top-level fn's body to fn ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body) (new_pats `zip` [spec_count..]) -- See Note [Specialise original body] @@ -2565,30 +2787,127 @@ data CallPat = CP { cp_qvars :: [Var] -- Quantified variables , cp_args :: [CoreExpr] -- Arguments , cp_strict_args :: [Var] -- Arguments we want to pass unlifted even if they are boxed -- See Note [SpecConstr and strict fields] - , cp_rebox :: [Name] } -- Constructors matched by this pattern whose box + , cp_rebox :: [Name] -- Constructors matched by this pattern whose box -- is also used; see Note [Reboxing warning] + , cp_callers :: [Name] } -- Enclosing top-level binders of the calls this + -- pattern came from; see Note [Reboxing warning] -- See Note [SpecConstr call patterns] instance Outputable CallPat where - ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict, cp_rebox = rebox }) + ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args = strict, cp_rebox = rebox + , cp_callers = callers }) = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma , text "cp_args =" <+> ppr args , text "cp_strict_args = " <> ppr strict - , text "cp_rebox = " <> ppr rebox ]) + , text "cp_rebox = " <> ppr rebox + , text "cp_callers = " <> ppr callers ]) + +-- | One call pattern as displayed by the reboxing warning: the shapes of +-- the pattern's arguments, and the reboxed constructors among them. +-- See Note [Reboxing warning] +data ReboxedPat = ReboxedPat [PatShape] [Name] + +-- | The constructor skeleton of one call-pattern argument, as displayed +-- by the reboxing warning +data PatShape = ShapeWild + | ShapeLit Literal + | ShapeCon DataCon [PatShape] + +-- | The displayed shapes of a pattern's value arguments +patShapes :: CallPat -> [PatShape] +patShapes (CP { cp_args = args }) = mapMaybe arg_shape args + where + arg_shape (Type {}) = Nothing + arg_shape (Coercion {}) = Nothing + arg_shape (Cast e _) = arg_shape e + arg_shape (Tick _ e) = arg_shape e + arg_shape (Lit l) = Just (ShapeLit l) + arg_shape e + | (Var f, f_args) <- collectArgs e + , Just dc <- isDataConWorkId_maybe f + = Just (ShapeCon dc (mapMaybe arg_shape f_args)) + | otherwise + = Just ShapeWild + +-- | Stable comparison, used both to merge identically-rendering warnings +-- and to order a warning's patterns deterministically +cmpReboxedPat :: ReboxedPat -> ReboxedPat -> Ordering +cmpReboxedPat (ReboxedPat ss1 cs1) (ReboxedPat ss2 cs2) + = cmpListBy cmpShape ss1 ss2 + `mappend` cmpListBy stableNameCmp (sortBy stableNameCmp cs1) + (sortBy stableNameCmp cs2) + +cmpShape :: PatShape -> PatShape -> Ordering +cmpShape ShapeWild ShapeWild = EQ +cmpShape ShapeWild _ = LT +cmpShape _ ShapeWild = GT +cmpShape (ShapeLit l1) (ShapeLit l2) = compare l1 l2 +cmpShape (ShapeLit _) _ = LT +cmpShape _ (ShapeLit _) = GT +cmpShape (ShapeCon c1 a1) (ShapeCon c2 a2) + = stableNameCmp (dataConName c1) (dataConName c2) + `mappend` cmpListBy cmpShape a1 a2 + +cmpListBy :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering +cmpListBy _ [] [] = EQ +cmpListBy _ [] _ = LT +cmpListBy _ _ [] = GT +cmpListBy cmp (x1:xs1) (x2:xs2) = cmp x1 x2 `mappend` cmpListBy cmp xs1 xs2 + +-- Constructors are shown by bare occurrence name: shapes illustrate, +-- while the warning's "reboxes" list identifies (with qualification) +pprPatShape :: PatShape -> SDoc +pprPatShape = go (10 :: Int) -- Depth cap against pathological patterns + where + go _ ShapeWild = underscore + go _ (ShapeLit l) = ppr l + go _ (ShapeCon dc []) = ppr (getOccName dc) + go 0 (ShapeCon {}) = text "..." + go d (ShapeCon dc args) + | isTupleDataCon dc + = parens (pprWithCommas (go d') args) + | isUnboxedTupleDataCon dc + = text "(#" <+> pprWithCommas (go d') args <+> text "#)" + | dataConIsInfix dc, [a1, a2] <- args + = parens (go d' a1 <+> pprInfixOcc (getOccName dc) <+> go d' a2) + | otherwise + = parens (pprPrefixOcc (getOccName dc) <+> sep (map (go d') args)) + where d' = d - 1 + +-- | How the function that SpecConstr specialised recurses, as bound in +-- the post-optimisation program. See Note [Reboxing warning] +data ReboxRecursivity + = ReboxSelfRec + | ReboxMutualRec [Name] -- The sibling binders of its Rec group + | ReboxNonRec Bool -- True <=> a join point data SpecConstrWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name } | SpecReboxed { spec_rebox_fun_name :: Name -- The specialised function - , spec_rebox_cons :: [Name] } -- The reboxed constructor(s) + , spec_rebox_fun_ty :: Type -- Its type: often the only clue + -- to a span-less function's identity + , spec_rebox_parent :: Maybe Name -- Its enclosing top-level + -- binder, if fn is local + , spec_rebox_recur :: ReboxRecursivity + , spec_rebox_pats :: [ReboxedPat] -- The patterns that rebox + , spec_rebox_callers :: [Name] } -- Top-level binders containing + -- the specialised calls -- See Note [Reboxing warning] - deriving Eq type SpecConstrWarnings = [SpecConstrWarning] instance Outputable SpecConstrWarning where ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name - ppr (SpecReboxed fn dcs) = ppr fn <+> parens (pprWithCommas ppr dcs) <+> pprDefinedAt fn + ppr (SpecReboxed fn _ty mb_parent _recur pats _callers) + = ppr fn <+> parens (pprWithCommas ppr dcs) <+> pp_defn + where + dcs = [ dc | ReboxedPat _ cons <- pats, dc <- cons ] + -- A local fn often has no useful location; point at its + -- enclosing top-level binder instead + pp_defn = case mb_parent of + Just parent -> text "in" <+> ppr parent <> comma <+> pprDefinedAt parent + Nothing -> pprDefinedAt fn combineSpecWarning :: SpecConstrWarnings -> SpecConstrWarnings -> SpecConstrWarnings combineSpecWarning = (++) @@ -2735,7 +3054,7 @@ callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule -callToPat env bndr_occs call@(Call fn args con_env) +callToPat env bndr_occs call@(Call fn args con_env mb_caller) = do { let in_scope = substInScopeSet (sc_subst env) ; arg_quads <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) @@ -2784,7 +3103,11 @@ callToPat env bndr_occs call@(Call fn args con_env) if interesting && null bad_covars then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats , cp_strict_args = concat cbv_ids - , cp_rebox = concat rebox_cons } + , cp_rebox = concat rebox_cons + -- Self-recursive calls are no clue + -- to the function's identity + , cp_callers = [ c | Just c <- [mb_caller] + , c /= idName fn ] } -- ; pprTraceM "callToPatOut" $ -- vcat [ text "fn:" <+> ppr fn -- , text "args:" <+> ppr args @@ -2888,8 +3211,10 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str ; let args' = [ p | (_, p, _, _) <- prs ] :: [CoreArg] cbvs = concat [ cbv | (_, _, cbv, _) <- prs ] rebox_nested = concat [ rbs | (_, _, _, rbs) <- prs ] - -- rebox_here: see Note [Reboxing warning] - rebox_here = [ dataConName dc | box_use == BoxOther ] + -- rebox_here: see Note [Reboxing warning]; nullary + -- constructors rebox for free, so don't warn about them + rebox_here = [ dataConName dc + | box_use == BoxOther, dataConRepArity dc > 0 ] ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) ( ppr con_str $$ ppr rest_args $$ ppr (length con_str) $$ ppr (length rest_args) ===================================== docs/users_guide/using-warnings.rst ===================================== @@ -534,6 +534,35 @@ of ``-W(no-)*``. the call-pattern analysis by wrapping the argument in ``GHC.Exts.lazy`` at the call site, or :ghc-flag:`-fno-spec-constr`. + The warning shows the specialised function's type, which is often the + clearest clue to its identity when its name carries no meaning, + followed by a block of labelled facts: ``source:`` — the function's + definition site (for a local function, also the enclosing top-level + binding); ``recursivity:`` — whether the function is self-recursive, + mutually recursive (naming the other functions of its recursive + group), or non-recursive (for example a join point), as bound in the + optimised program, whose shape can differ from the source's; + ``called from:`` — the top-level bindings containing the specialised + calls; ``call patterns:`` — the calls the function was specialised + for, shown as the constructor skeletons of their arguments, each + alongside the constructors that the specialisation reboxes (for + example ``go (_ : _) (Bin _ _ _) -- reboxes ‘Bin’``). One warning is emitted per + specialised function, and warnings that would read identically are + merged into one. Specialisations on nullary constructors are not + reported, since "reboxing" a nullary constructor simply references + its shared static closure. + + A ``source:`` reading ``inlined from another module (no source + location)`` concerns a function that reached the module being compiled + through another module's unfolding; interface files record no source + locations for local functions. Such reboxing cannot be addressed in + the module being compiled — consider reporting it against the package + defining the inlined code. Constructors imported from other modules + are shown qualified with their defining module as a hint to where that + is. For such a warning the ``called from:`` sites are the only located + code — following the inlining from one of them identifies the reboxed + code. + The analysis behind this warning is approximate: it can both miss genuine reboxing and report reboxing that later optimisations eliminate or that only occurs on cold code paths. ===================================== testsuite/tests/simplCore/should_compile/T27628.stderr ===================================== @@ -1,9 +1,14 @@ T27628.hs: warning: [-Wspec-constr-reboxing] - SpecConstr specialised the following function(s) on a constructor argument that is also used boxed: - $wgo (LC) Defined at T27628.hs:17:1 - The specialised code allocates a fresh constructor at each such use ("reboxing"), - which can increase allocation and defeat pointer-equality-based sharing. - Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma, - hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy, - or use -fno-spec-constr. + SpecConstr specialised + ‘$wgo :: LC + -> GHC.Internal.Prim.Int# + -> GHC.Internal.Prim.Int# + -> GHC.Internal.Prim.Int#’ + source: T27628.hs:17:1 + recursivity: self-recursive + called from: ‘f’ + call pattern: $wgo (LC _ _) -- reboxes ‘LC’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. ===================================== testsuite/tests/simplCore/should_compile/T27628b.stderr ===================================== @@ -1,9 +1,10 @@ T27628b.hs: warning: [-Wspec-constr-reboxing] - SpecConstr specialised the following function(s) on a constructor argument that is also used boxed: - merge (Bin) Defined at T27628b.hs:10:1 - The specialised code allocates a fresh constructor at each such use ("reboxing"), - which can increase allocation and defeat pointer-equality-based sharing. - Possible remedies: exclude the type with an {-# ANN type T NoSpecConstr #-} pragma, - hide the constructor from SpecConstr by wrapping the call-site argument in GHC.Exts.lazy, - or use -fno-spec-constr. + SpecConstr specialised ‘merge :: T -> T -> T’ + source: T27628b.hs:10:1 + recursivity: self-recursive + called from: ‘f’ + call pattern: merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. ===================================== testsuite/tests/simplCore/should_compile/T27628e.hs ===================================== @@ -0,0 +1,17 @@ +-- Like T27628b, but the specialisation pattern is the *nullary* +-- constructor Tip (the call passes Tip; the box is also returned). +-- Reboxing a nullary constructor is free (it is a shared static +-- closure), so no warning should be emitted. +module T27628e where + +data T = Tip | Bin Int T T + +merge :: T -> T -> T +merge Tip t2 = t2 +merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2) + +g :: T -> T +g t = merge t Tip ===================================== testsuite/tests/simplCore/should_compile/T27628f.hs ===================================== @@ -0,0 +1,16 @@ +-- Like T27628b, but the specialised function is a *local* worker. +-- The warning should attribute it to the enclosing top-level binder f. +-- (merge captures n so that it is not floated to the top level.) +module T27628f where + +data T = Tip | Bin Int T T + +f :: Int -> T -> T +f n t0 = merge (Bin n Tip Tip) t0 + where + merge :: T -> T -> T + merge Tip _ = Tip + merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin (k + n) (merge l l2) (merge r r2) ===================================== testsuite/tests/simplCore/should_compile/T27628f.stderr ===================================== @@ -0,0 +1,10 @@ +T27628f.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘merge :: T -> T -> T’ + source: ‘f’ at T27628f.hs:12:5 + recursivity: self-recursive + called from: ‘f’ + call pattern: merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628g.hs ===================================== @@ -0,0 +1,15 @@ +module T27628g where + +data T a = Tip | Bin a (T a) (T a) + +-- merge has no free value variables, so the float-out pass lifts it to +-- top level as poly_merge, abstracted over 'a'. The reboxing warning +-- should still point at merge's definition site. +f :: a -> T a -> T a +f x t = merge (Bin x Tip Tip) t + where + merge Tip t2 = t2 + merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2) ===================================== testsuite/tests/simplCore/should_compile/T27628g.stderr ===================================== @@ -0,0 +1,10 @@ +T27628g.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’ + source: T27628g.hs:11:5 + recursivity: self-recursive + called from: ‘f’ + call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628h.hs ===================================== @@ -0,0 +1,8 @@ +-- Specialising the span-less copy of T27628h_M.merge must warn with the +-- "inlined from another module" wording and a module-qualified constructor. +module T27628h where + +import T27628h_M + +g :: Int -> T Int -> T Int +g x t = f x (f x t) ===================================== testsuite/tests/simplCore/should_compile/T27628h.stderr ===================================== @@ -0,0 +1,20 @@ +./T27628h_M.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’ + source: T27628h_M.hs:11:5 + recursivity: self-recursive + called from: ‘f’ + call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628h.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘merge :: T Int -> T Int -> T Int’ + source: inlined from another module (no source location) + recursivity: self-recursive + called from: ‘g’ + call pattern: merge (Bin _ _ _) -- reboxes ‘T27628h_M.Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628h_M.hs ===================================== @@ -0,0 +1,16 @@ +-- The INLINE unfolding of f carries the local loop 'merge' into importing +-- modules, where it is specialised without a source span: iface unfoldings +-- record no spans for local binders. +module T27628h_M where + +data T a = Tip | Bin a (T a) (T a) + +f :: a -> T a -> T a +f x t = merge (Bin x Tip Tip) t + where + merge Tip t2 = t2 + merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2) +{-# INLINE f #-} ===================================== testsuite/tests/simplCore/should_compile/T27628i.hs ===================================== @@ -0,0 +1,15 @@ +-- The span-less copies of f1's and f3's 'merge' render identically, so +-- one warning covers both; f2's 'merge' differs in type and gets its +-- own warning. +module T27628i where + +import T27628i_M + +g1 :: Int -> T Int -> T Int +g1 x t = f1 x (f1 x t) + +g2 :: Int -> S Int -> S Int +g2 x t = f2 x (f2 x t) + +g3 :: Int -> T Int -> T Int +g3 x t = f3 x (f3 x t) ===================================== testsuite/tests/simplCore/should_compile/T27628i.stderr ===================================== @@ -0,0 +1,51 @@ +./T27628i_M.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’ + source: T27628i_M.hs:36:5 + recursivity: self-recursive + called from: ‘f3’ + call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +./T27628i_M.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘poly_merge :: S a -> S a -> S a’ + source: T27628i_M.hs:24:5 + recursivity: self-recursive + called from: ‘f2’ + call pattern: poly_merge (Node _ _ _) -- reboxes ‘Node’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +./T27628i_M.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘poly_merge :: T a -> T a -> T a’ + source: T27628i_M.hs:14:5 + recursivity: self-recursive + called from: ‘f1’ + call pattern: poly_merge (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628i.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘merge :: T Int -> T Int -> T Int’ + source: inlined from another module (no source location) + recursivity: self-recursive + called from: ‘g1’, ‘g3’ + call pattern: merge (Bin _ _ _) -- reboxes ‘T27628i_M.Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628i.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘merge :: S Int -> S Int -> S Int’ + source: inlined from another module (no source location) + recursivity: self-recursive + called from: ‘g2’ + call pattern: merge (Node _ _ _) + -- reboxes ‘T27628i_M.Node’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628i_M.hs ===================================== @@ -0,0 +1,41 @@ +-- Three INLINE functions with local loops named 'merge': f1 and f3 over +-- T, f2 over S. In an importing module all three loops arrive span-less +-- (iface unfoldings record no spans for local binders). f1's and f3's +-- copies render identically (same name and type) and must merge into +-- one warning; f2's differs in type and must stay separate. +module T27628i_M where + +data T a = Tip | Bin a (T a) (T a) +data S a = Leaf | Node a (S a) (S a) + +f1 :: a -> T a -> T a +f1 x t = merge (Bin x Tip Tip) t + where + merge Tip t2 = t2 + merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (merge l l2) (merge r r2) +{-# INLINE f1 #-} + +f2 :: a -> S a -> S a +f2 x t = merge (Node x Leaf Leaf) t + where + merge Leaf t2 = t2 + merge t1@(Node k l r) t2 = + case t2 of + Leaf -> t1 + Node _ l2 r2 -> Node k (merge l l2) (merge r r2) +{-# INLINE f2 #-} + +-- Like f1 but recursing with the children swapped, so the two loops +-- stay distinct functions while their warnings render the same +f3 :: a -> T a -> T a +f3 x t = merge (Bin x Tip Tip) t + where + merge Tip t2 = t2 + merge t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (merge r r2) (merge l l2) +{-# INLINE f3 #-} ===================================== testsuite/tests/simplCore/should_compile/T27628j.hs ===================================== @@ -0,0 +1,24 @@ +-- A mutually recursive pair in the style of T27628b. g calls both +-- functions with a constructor argument: the non-loop-breaker inlines +-- into g, but the loop breaker's call survives to SpecConstr, whose +-- warning classifies it as mutually recursive and names the sibling. +module T27628j where + +data T = Tip | Bin Int T T + +mergeA :: T -> T -> T +mergeA Tip t2 = t2 +mergeA t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (mergeB l l2) (mergeB r r2) + +mergeB :: T -> T -> T +mergeB Tip t2 = t2 +mergeB t1@(Bin k l r) t2 = + case t2 of + Tip -> t1 + Bin _ l2 r2 -> Bin k (mergeA r r2) (mergeA l l2) + +g :: Int -> T -> T +g x t = mergeA (Bin x Tip Tip) (mergeB (Bin x Tip Tip) t) ===================================== testsuite/tests/simplCore/should_compile/T27628j.stderr ===================================== @@ -0,0 +1,10 @@ +T27628j.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘mergeB :: T -> T -> T’ + source: T27628j.hs:17:1 + recursivity: mutually recursive with ‘mergeA’ + called from: ‘g’ + call pattern: mergeB (Bin _ _ _) -- reboxes ‘Bin’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628k.hs ===================================== @@ -0,0 +1,20 @@ +-- 'go' is specialised for two different call patterns, A and B, and +-- both rebox (t is scrutinised but also passed whole to 'sink'). +-- Expect one warning for 'go' listing both call patterns. +module T27628k where + +data T = A Int | B Int | C + +-- The guard makes the use of 't' lazy, so boxity analysis keeps the +-- box: $wsink wants it. +sink :: T -> Int -> Int +sink t k + | k < 0 = k + | otherwise = case t of A n -> n; B n -> n; C -> 0 +{-# NOINLINE sink #-} + +go :: T -> Int -> Int +go t k = case t of + A n -> if k == 0 then sink t k else go (B n) (k - 1) + B n -> if k == 0 then sink t k else go (A n) (k - 1) + C -> 0 ===================================== testsuite/tests/simplCore/should_compile/T27628k.stderr ===================================== @@ -0,0 +1,11 @@ +T27628k.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘go :: T -> Int -> Int’ + source: T27628k.hs:17:1 + recursivity: self-recursive + call patterns: go (A _) (I# _) -- reboxes ‘A’ + go (B _) (I# _) -- reboxes ‘B’ + These constructor arguments are also used boxed, so the + specialisations may increase allocation and defeat + pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/T27628l.hs ===================================== @@ -0,0 +1,38 @@ +-- Max and Min (mimicking GHC.Internal.Data.Functor.Utils) both inline +-- base's foldl' and stimes templates, so each instance's methods bind +-- local loops with the SAME uniques as the other's. The warnings must +-- stay separate per instance (keyed on (parent, function)), not be +-- fused into one with doubled callers; see Note [Reboxing warning]. +module T27628l where + +import Data.List (foldl') + +newtype Max a = Max (Maybe a) + +instance Ord a => Semigroup (Max a) where + {-# INLINE (<>) #-} + m <> Max Nothing = m + Max Nothing <> n = n + (Max m@(Just x)) <> (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + +instance Ord a => Monoid (Max a) where + mempty = Max Nothing + mconcat = foldl' (<>) mempty + {-# INLINE mconcat #-} + +newtype Min a = Min (Maybe a) + +instance Ord a => Semigroup (Min a) where + {-# INLINE (<>) #-} + m <> Min Nothing = m + Min Nothing <> n = n + (Min m@(Just x)) <> (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n + +instance Ord a => Monoid (Min a) where + mempty = Min Nothing + mconcat = foldl' (<>) mempty + {-# INLINE mconcat #-} ===================================== testsuite/tests/simplCore/should_compile/T27628l.stderr ===================================== @@ -0,0 +1,66 @@ +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘go1 :: [Max a] -> Max a -> Max a’ + source: ‘$cmconcat’ at T27628l.hs:22:5 + recursivity: self-recursive + called from: ‘$cmconcat’ + call pattern: go1 _ (Just _) + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘exit :: Max a -> b -> Max a’ + source: ‘$cstimes’ at T27628l.hs:12:10 + recursivity: non-recursive (a join point) + called from: ‘$cstimes’ + call pattern: exit (Just _) _ + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘g :: Max a -> b -> Max a -> Max a’ + source: ‘$cstimes’ at T27628l.hs:12:10 + recursivity: self-recursive + called from: ‘$cstimes’ + call pattern: g (Just _) _ _ + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘go1 :: [Min a] -> Min a -> Min a’ + source: ‘$cmconcat’ at T27628l.hs:37:5 + recursivity: self-recursive + called from: ‘$cmconcat’ + call pattern: go1 _ (Just _) + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘exit :: Min a -> b -> Min a’ + source: ‘$cstimes’ at T27628l.hs:27:10 + recursivity: non-recursive (a join point) + called from: ‘$cstimes’ + call pattern: exit (Just _) _ + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + +T27628l.hs: warning: [-Wspec-constr-reboxing] + SpecConstr specialised ‘g :: Min a -> b -> Min a -> Min a’ + source: ‘$cstimes’ at T27628l.hs:27:10 + recursivity: self-recursive + called from: ‘$cstimes’ + call pattern: g (Just _) _ _ + -- reboxes ‘GHC.Internal.Maybe.Just’ + This constructor argument is also used boxed, so the specialisation + may increase allocation and defeat pointer-equality-based sharing. + See -Wspec-constr-reboxing in the users guide for possible remedies. + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -617,3 +617,11 @@ test('T27628', normal, compile, ['-O2 -Wspec-constr-reboxing']) test('T27628b', normal, compile, ['-O2 -Wspec-constr-reboxing']) test('T27628c', normal, compile, ['-O2 -Wspec-constr-reboxing']) test('T27628d', normal, compile, ['-O2 -Wspec-constr-reboxing']) +test('T27628e', normal, compile, ['-O2 -Wspec-constr-reboxing']) +test('T27628f', normal, compile, ['-O2 -Wspec-constr-reboxing']) +test('T27628g', normal, compile, ['-O2 -Wspec-constr-reboxing -dsuppress-uniques']) +test('T27628h', [extra_files(['T27628h_M.hs'])], multimod_compile, ['T27628h', '-v0 -O2 -Wspec-constr-reboxing -dsuppress-uniques']) +test('T27628i', [extra_files(['T27628i_M.hs'])], multimod_compile, ['T27628i', '-v0 -O2 -Wspec-constr-reboxing -dsuppress-uniques']) +test('T27628j', normal, compile, ['-O2 -Wspec-constr-reboxing']) +test('T27628k', normal, compile, ['-O2 -Wspec-constr-reboxing']) +test('T27628l', normal, compile, ['-O2 -Wspec-constr-reboxing -dsuppress-uniques']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e9f8bc7f5d8acf390e0145030dbbe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0e9f8bc7f5d8acf390e0145030dbbe… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 84b9fd2f by Andreas Klebinger at 2026-08-24T02:45:47-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 7e4eb741 by Alan Zimmerman at 2026-08-24T02:45:47-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c816680d958ebed747a4ef9e7353e5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c816680d958ebed747a4ef9e7353e5… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: eb28622d by Andreas Klebinger at 2026-08-24T00:38:04-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - c816680d by Alan Zimmerman at 2026-08-24T00:38:04-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5af7613fd719b1541ee93ac41f5a71… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5af7613fd719b1541ee93ac41f5a71… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 79765ad4 by Andreas Klebinger at 2026-08-23T20:29:30-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 5af7613f by Alan Zimmerman at 2026-08-23T20:29:30-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e54da4bb5ca046002f3cd727baa93c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e54da4bb5ca046002f3cd727baa93c… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/T27727] haddock: Fix overeager defaulting
by Krzysztof Gogolewski (＠monoidal) 24 Aug '26

24 Aug '26

Krzysztof Gogolewski pushed to branch wip/T27727 at Glasgow Haskell Compiler / GHC Commits: bcb7d61a by Krzysztof Gogolewski at 2026-08-24T00:23:53+02:00 haddock: Fix overeager defaulting When defaulting RuntimeReps, we don't want to display forall (f :: forall r. TYPE r -> Type) . f Int# -> f Int# as forall (f :: Type -> Type) . f Int# -> f Int# because that's ill-kinded. This was already fixed in GHC in #16468, but Haddock has its own defaulting which needs a similar change. Fixes #27727. - - - - - 5 changed files: - compiler/GHC/Iface/Type.hs - utils/haddock/haddock-api/src/Haddock/GhcUtils.hs - utils/haddock/html-test/Main.hs - + utils/haddock/html-test/ref/T27727.html - + utils/haddock/html-test/src/T27727.hs Changes: ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -1258,6 +1258,8 @@ Wrinkles: The toplevel function type is matched as IfaceFunTy, where we recurse into 'go' by passing False for 'rank1'. The forall in the first argument then skips adding a substitution for 'r2'. + The same wrinkle applies to Haddock, which has its own copy of defaulting + in 'defaultRuntimeRepVars'. (W2) 'defaultIfaceTyVarsOfKind' ought to be called only once when printing a type. ===================================== utils/haddock/haddock-api/src/Haddock/GhcUtils.hs ===================================== @@ -843,37 +843,40 @@ orderedFVs ignore_tvs tys ------------------------------------------------------------------------------- --- | Traverses the type, defaulting type variables of kind 'RuntimeRep' to --- 'LiftedType'. See 'defaultRuntimeRepVars' in GHC.Iface.Type the original such +-- | Traverses the type, defaulting top-level type variables of kind 'RuntimeRep' to +-- 'LiftedType'. See 'defaultIfaceTyVarsOfKind' in GHC.Iface.Type the original such -- function working over `IfaceType`'s. defaultRuntimeRepVars :: Type -> Type -defaultRuntimeRepVars = go emptyVarEnv +defaultRuntimeRepVars = go True emptyVarEnv where - go :: TyVarEnv () -> Type -> Type - go subs (ForAllTy (Bndr var flg) ty) - | isRuntimeRepVar var + go :: Bool -> TyVarEnv () -> Type -> Type + -- See Wrinkle (W1) in Note [Defaulting RuntimeRep variables] in GHC.Iface.Type + -- for why we have the 'rank1' parameter. + go rank1 subs (ForAllTy (Bndr var flg) ty) + | rank1 + , isRuntimeRepVar var , isInvisibleForAllTyFlag flg = let subs' = extendVarEnv subs var () - in go subs' ty + in go rank1 subs' ty | otherwise = ForAllTy - (Bndr (updateTyVarKind (go subs) var) flg) - (go subs ty) - go subs (TyVarTy tv) + (Bndr (updateTyVarKind (go False subs) var) flg) + (go rank1 subs ty) + go _ subs (TyVarTy tv) | tv `elemVarEnv` subs = liftedRepTy | otherwise = - TyVarTy (updateTyVarKind (go subs) tv) - go subs (TyConApp tc tc_args) = - TyConApp tc (map (go subs) tc_args) - go subs (FunTy af w arg res) = - FunTy af (go subs w) (go subs arg) (go subs res) - go subs (AppTy t u) = - AppTy (go subs t) (go subs u) - go subs (CastTy x co) = - CastTy (go subs x) co - go _ ty@(LitTy{}) = ty - go _ ty@(CoercionTy{}) = ty + TyVarTy (updateTyVarKind (go False subs) tv) + go _ subs (TyConApp tc tc_args) = + TyConApp tc (map (go False subs) tc_args) + go rank1 subs (FunTy af w arg res) = + FunTy af (go False subs w) (go False subs arg) (go rank1 subs res) + go _ subs (AppTy t u) = + AppTy (go False subs t) (go False subs u) + go rank1 subs (CastTy x co) = + CastTy (go rank1 subs x) co + go _ _ ty@(LitTy{}) = ty + go _ _ ty@(CoercionTy{}) = ty fromMaybeContext :: Maybe (LHsContext DocNameI) -> HsContext DocNameI fromMaybeContext Nothing = HsContext noExtField [] ===================================== utils/haddock/html-test/Main.hs ===================================== @@ -53,8 +53,8 @@ stripIfRequired mdl = preserveLinksModules :: [String] preserveLinksModules = ["Bug253.html", "NamespacedIdentifiers.html"] -ingoredTests :: [String] -ingoredTests = +ignoredTests :: [String] +ignoredTests = [ -- Currently some declarations are exported twice -- we need a reliable way to deduplicate here. @@ -76,6 +76,6 @@ ignoredOneShotTests = ] checkIgnore :: FilePath -> Bool -checkIgnore file | takeBaseName file `elem` ingoredTests = True +checkIgnore file | takeBaseName file `elem` ignoredTests = True checkIgnore file@(c:_) | takeExtension file == ".html" && isUpper c = False checkIgnore _ = True ===================================== utils/haddock/html-test/ref/T27727.html ===================================== @@ -0,0 +1,84 @@ +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><meta name="viewport" content="width=device-width, initial-scale=1" + /><title + >T27727</title + ><link href="#" rel="stylesheet" type="text/css" title="Linuwial" + /><link rel="stylesheet" type="text/css" href="#" + /><link rel="stylesheet" type="text/css" href="#" + /><script src="haddock-bundle.min.js" async="async" type="text/javascript" + ></script + ><script type="text/x-mathjax-config" + >MathJax.Hub.Config({ tex2jax: { processClass: "mathjax", ignoreClass: ".*" } });</script + ><script src="https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-…" type="text/javascript" + ></script + ></head + ><body + ><div id="package-header" + ><span class="caption empty" + > </span + ><ul class="links" id="page-menu" + ><li + ><a href="#" + >Contents</a + ></li + ><li + ><a href="#" + >Index</a + ></li + ></ul + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >T27727</p + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a id="v:demonstration" class="def" + >demonstration</a + > :: <span class="keyword" + >forall</span + > (f :: <span class="keyword" + >forall</span + > r. <a href="#" title="GHC.Exts" + >TYPE</a + > r -> <a href="#" title="Data.Kind" + >Type</a + >). f <a href="#" title="GHC.Exts" + >Int#</a + > -> f <a href="#" title="GHC.Exts" + >Int#</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a id="v:f" class="def" + >f</a + > :: (<span class="keyword" + >forall</span + > r. P r) -> P <a href="#" title="GHC.Exts" + >LiftedRep</a + > <a href="#" class="selflink" + >#</a + ></p + ></div + ></div + ></div + ></body + ></html +> ===================================== utils/haddock/html-test/src/T27727.hs ===================================== @@ -0,0 +1,16 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} + +module T27727 (demonstration, f) where + +import Data.Kind (Type) +import GHC.Exts (Int#, TYPE, RuntimeRep) + +demonstration :: forall (f :: forall r. TYPE r -> Type) . f Int# -> f Int# +demonstration x = x + +data P :: RuntimeRep -> Type + +f :: (forall r. P r) -> P s +f x = x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb7d61a4c3ec0fb738c23e54346b0b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcb7d61a4c3ec0fb738c23e54346b0b… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64
by Marge Bot (＠marge-bot) 24 Aug '26

24 Aug '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 312547b7 by Andreas Klebinger at 2026-08-23T16:17:50-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - e54da4bb by Alan Zimmerman at 2026-08-23T16:17:51-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 6 changed files: - rts/linker/elf_reloc_riscv64.c - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63fc04560835be2a6655fc15b7cc93… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63fc04560835be2a6655fc15b7cc93… You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0

[Git][ghc/ghc] Deleted branch wip/split-sections-scc
by Cheng Shao (＠TerrorJack) 24 Aug '26

24 Aug '26

Cheng Shao deleted branch wip/split-sections-scc at Glasgow Haskell Compiler / GHC -- You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

1 0