- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/fendor/hpc-bc-support] Add more tests for ghci and -fhpc
by Hannes Siebenhandl (＠fendor) 03 Apr '26

03 Apr '26

Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC Commits: dca9e699 by fendor at 2026-04-03T10:01:43+02:00 Add more tests for ghci and -fhpc - - - - - 24 changed files: - testsuite/tests/hpc/Makefile - testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout - + testsuite/tests/hpc/T17073b.stdout - testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout - + testsuite/tests/hpc/T20568b.stdout - testsuite/tests/hpc/all.T - testsuite/tests/hpc/fork/Makefile - + testsuite/tests/hpc/function/hpcrun.sh - testsuite/tests/hpc/function/test.T - + testsuite/tests/hpc/function/tough1.script - + testsuite/tests/hpc/function/tough1.stderr - + testsuite/tests/hpc/function/tough1.stdout - testsuite/tests/hpc/function2/test.T - + testsuite/tests/hpc/function2/tough3.script - testsuite/tests/hpc/ghc_ghci/Makefile - testsuite/tests/hpc/hpcrun.pl - testsuite/tests/hpc/simple/Makefile - + testsuite/tests/hpc/simple/hpc002.hs - + testsuite/tests/hpc/simple/hpc002.stdout - + testsuite/tests/hpc/simple/hpc003.hs - + testsuite/tests/hpc/simple/hpc003.script - + testsuite/tests/hpc/simple/hpc003.stderr - + testsuite/tests/hpc/simple/hpc003.stdout - testsuite/tests/hpc/simple/test.T Changes: ===================================== testsuite/tests/hpc/Makefile ===================================== @@ -1,4 +1,4 @@ -TOP=../.. +TOP=/home/hugin/Documents/haskell/ghc-hpc-bc/testsuite include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk @@ -8,13 +8,22 @@ T11798: "$(TEST_HC)" $(TEST_HC_ARGS) T11798 -fhpc test -e .hpc/T11798.mix -T17073: +T17073a: LANG=ASCII "$(TEST_HC)" $(TEST_HC_ARGS) T17073.hs -fhpc -v0 ./T17073 "$(HPC)" report T17073 "$(HPC)" version LANG=ASCII "$(HPC)" markup T17073 -T20568: +T17073b: + "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) T17073.hs -fhpc -v0 -e ":main" + "$(HPC)" report ghc + "$(HPC)" version + LANG=ASCII "$(HPC)" markup ghc + +T20568a: "$(TEST_HC)" $(TEST_HC_ARGS) T20568.hs -fhpc -v0 ./T20568 + +T20568b: + "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) T20568.hs -fhpc -v0 -e ":main" ===================================== testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout ===================================== @@ -12,4 +12,4 @@ Writing: Main.hs.html Writing: hpc_index.html Writing: hpc_index_fun.html Writing: hpc_index_alt.html -Writing: hpc_index_exp.html \ No newline at end of file +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/T17073b.stdout ===================================== @@ -0,0 +1,15 @@ +Добрый день +100% expressions used (2/2) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +hpc tools, version 0.69 +Writing: Main.hs.html +Writing: hpc_index.html +Writing: hpc_index_fun.html +Writing: hpc_index_alt.html +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout ===================================== ===================================== testsuite/tests/hpc/T20568b.stdout ===================================== @@ -0,0 +1 @@ +IfThenElse (AstBool True) (AstInt 1) (AstInt 2) ===================================== testsuite/tests/hpc/all.T ===================================== @@ -23,7 +23,10 @@ test('T2991', [cmd_wrapper(T2991)], # Run with 'ghc --main'. Do not list other modules explicitly. multimod_compile_and_run, ['T2991', '']) -test('T17073', when(opsys('mingw32'), expect_broken(17607)), - makefile_test, ['T17073 HPC={hpc}']) +test('T17073a', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], + makefile_test, ['T17073a HPC={hpc}']) +test('T17073b', [when(opsys('mingw32'), expect_broken(17607)), extra_files(['T17073.hs'])], + makefile_test, ['T17073b HPC={hpc}']) -test('T20568', normal, makefile_test, []) +test('T20568a', [extra_files(['T20568.hs'])], makefile_test, []) +test('T20568b', [extra_files(['T20568.hs'])], makefile_test, []) ===================================== testsuite/tests/hpc/fork/Makefile ===================================== @@ -1,4 +1,3 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk - ===================================== testsuite/tests/hpc/function/hpcrun.sh ===================================== @@ -0,0 +1,48 @@ +#!/usr/bin/env bash + +while [[ $1 == --* ]]; do + arg=$1; shift + case $arg in + --) break ;; + --hpc=*) HPC=${arg#--hpc=} ;; + --clear) CLEAR=1 ;; + --exeext=*) exeext=${arg#--exeext=} ;; + *) echo "Bad arg: $arg" >&2; exit 1 ;; + esac +done + +[[ -z $HPC ]] && { echo "no option --hpc=* provided" >&2; exit 1; } + +# Skip KEY=VALUE assignments to find the real executable +exe="" +for arg in "$@"; do + [[ $arg =~ ^[A-Za-z_][A-Za-z0-9_]*= ]] && continue + exe=$arg + break +done + +binary=$(basename "$exe")$exeext + +[[ -n $CLEAR ]] && rm -f "$binary.tix" + +# Reconstruct with quoted arguments +cmd="" +for arg in "$@"; do + cmd+=" $(printf '%q' "$arg")" +done +bash -c "$cmd" +echo + +$HPC report "$binary.tix" +echo + +$HPC report "$binary.tix" --per-module +echo + +$HPC markup "$binary.tix" | while IFS= read -r line; do + echo "$line" + if [[ $line =~ Writing:\ ([^[:space:]]+\.html) ]]; then + cat "${BASH_REMATCH[1]}" + fi +done +echo ===================================== testsuite/tests/hpc/function/test.T ===================================== @@ -1,6 +1,6 @@ -setTestOpts([omit_ghci, when(fast(), skip), js_skip]) +setTestOpts([when(fast(), skip), js_skip]) -hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}" +hpc_prefix = "./hpcrun.sh --clear --exeext={exeext} --hpc={hpc} --" test('tough', [extra_files(['../hpcrun.pl']), @@ -8,3 +8,11 @@ test('tough', ignore_extension, when(arch('wasm32'), fragile(23243))], compile_and_run, ['-fhpc']) + +test('tough1', + [extra_files(['hpcrun.sh', 'tough.hs']), + cmd_prefix(hpc_prefix), + ignore_extension, + extra_hc_opts('-fhpc tough.hs'), + when(arch('wasm32'), fragile(23243))], + ghci_script, ['tough1.script']) ===================================== testsuite/tests/hpc/function/tough1.script ===================================== @@ -0,0 +1,2 @@ +main +:quit ===================================== testsuite/tests/hpc/function/tough1.stderr ===================================== @@ -0,0 +1,4 @@ +tough.hs:22:5: warning: [GHC-53633] [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: _ -> ... + ===================================== testsuite/tests/hpc/function/tough1.stdout ===================================== @@ -0,0 +1,127 @@ +"Hello" +"Hello" +badCase +badCase +"Bark" +"Hello" +(1,2,3) + + 73% expressions used (73/100) + 14% boolean coverage (1/7) + 0% guards (0/4), 3 always True, 1 always False + 33% 'if' conditions (1/3), 1 always True, 1 always False + 100% qualifiers (0/0) + 58% alternatives used (7/12) +100% local declarations used (0/0) + 83% top-level declarations used (5/6) + +-----<module Main>----- + 73% expressions used (73/100) + 14% boolean coverage (1/7) + 0% guards (0/4), 3 always True, 1 always False + 33% 'if' conditions (1/3), 1 always True, 1 always False + 100% qualifiers (0/0) + 58% alternatives used (7/12) +100% local declarations used (0/0) + 83% top-level declarations used (5/6) + +Writing: Main.hs.html +<html> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +<style type="text/css"> +span.lineno { color: white; background: #aaaaaa; border-right: solid white 12px } +span.nottickedoff { background: yellow} +span.istickedoff { background: white } +span.tickonlyfalse { margin: -1px; border: 1px solid #f20913; background: #f20913 } +span.tickonlytrue { margin: -1px; border: 1px solid #60de51; background: #60de51 } +span.funcount { font-size: small; color: orange; z-index: 2; position: absolute; right: 20 } +span.decl { font-weight: bold } +span.spaces { background: white } +</style> +</head> +<body> +<pre> +<span class="decl"><span class="nottickedoff">never executed</span> <span class="tickonlytrue">always true</span> <span class="tickonlyfalse">always false</span></span> +</pre> +<pre> +<span class="lineno"> 1 </span>import Control.Exception as E +<span class="lineno"> 2 </span> +<span class="lineno"> 3 </span>-- This test shows what hpc can really do. +<span class="lineno"> 4 </span> +<span class="lineno"> 5 </span><span class="decl"><span class="istickedoff">main = do</span> +<span class="lineno"> 6 </span><span class="spaces"> </span><span class="istickedoff">print ("Hello")</span> +<span class="lineno"> 7 </span><span class="spaces"> </span><span class="istickedoff">foo "Hello"</span> +<span class="lineno"> 8 </span><span class="spaces"> </span><span class="istickedoff">E.catch (print (badCase 22 <span class="nottickedoff">44</span>))</span> +<span class="lineno"> 9 </span><span class="spaces"> </span><span class="istickedoff">(\ e -> print (e :: E.ErrorCall))</span> +<span class="lineno"> 10 </span><span class="spaces"> </span><span class="istickedoff">E.catch (print (badCase 22 <span class="nottickedoff">(error "Foo")</span>))</span> +<span class="lineno"> 11 </span><span class="spaces"> </span><span class="istickedoff">(\ e -> print (e :: E.ErrorCall))</span> +<span class="lineno"> 12 </span><span class="spaces"> </span><span class="istickedoff">E.catch (print "Bark")</span> +<span class="lineno"> 13 </span><span class="spaces"> </span><span class="istickedoff"><span class="nottickedoff">(\ e -> print (e :: E.ErrorCall))</span></span> +<span class="lineno"> 14 </span><span class="spaces"> </span><span class="istickedoff">(_,_) <- return $ (<span class="nottickedoff">"Hello"</span>,<span class="nottickedoff">"World"</span>)</span> +<span class="lineno"> 15 </span><span class="spaces"> </span><span class="istickedoff">return <span class="nottickedoff">()</span></span> +<span class="lineno"> 16 </span><span class="spaces"> </span><span class="istickedoff">() <- return ()</span> +<span class="lineno"> 17 </span><span class="spaces"> </span><span class="istickedoff">t <- case <span class="nottickedoff">()</span> of</span> +<span class="lineno"> 18 </span><span class="spaces"> </span><span class="istickedoff">_ | <span class="tickonlytrue">otherwoz</span> -> return <span class="nottickedoff">"Hello"</span></span> +<span class="lineno"> 19 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">error "Bad Thing Happened"</span></span> +<span class="lineno"> 20 </span><span class="spaces"> </span><span class="istickedoff">t <- case <span class="nottickedoff">()</span> of</span> +<span class="lineno"> 21 </span><span class="spaces"> </span><span class="istickedoff">_ | <span class="tickonlytrue">otherwise</span> -> return <span class="nottickedoff">"Hello"</span></span> +<span class="lineno"> 22 </span><span class="spaces"> </span><span class="istickedoff">_ -> <span class="nottickedoff">error "Bad Thing Happened"</span></span> +<span class="lineno"> 23 </span><span class="spaces"> </span><span class="istickedoff">t <- case <span class="nottickedoff">()</span> of</span> +<span class="lineno"> 24 </span><span class="spaces"> </span><span class="istickedoff">_ | <span class="tickonlytrue">otherwise</span> </span> +<span class="lineno"> 25 </span><span class="spaces"> </span><span class="istickedoff">, <span class="tickonlyfalse">False</span> -> <span class="nottickedoff">error "Bad Thing Happened"</span></span> +<span class="lineno"> 26 </span><span class="spaces"> </span><span class="istickedoff">_ -> return "Hello"</span> +<span class="lineno"> 27 </span><span class="spaces"> </span><span class="istickedoff">print t</span> +<span class="lineno"> 28 </span><span class="spaces"> </span><span class="istickedoff">print foo2</span></span> +<span class="lineno"> 29 </span> +<span class="lineno"> 30 </span><span class="decl"><span class="istickedoff">foo x = do</span> +<span class="lineno"> 31 </span><span class="spaces"> </span><span class="istickedoff">print x</span> +<span class="lineno"> 32 </span><span class="spaces"> </span><span class="istickedoff">return <span class="nottickedoff">()</span></span></span> +<span class="lineno"> 33 </span> +<span class="lineno"> 34 </span><span class="decl"><span class="nottickedoff">unused_ a = a</span></span> +<span class="lineno"> 35 </span> +<span class="lineno"> 36 </span>badCase :: Int -> Int -> Int +<span class="lineno"> 37 </span><span class="decl"><span class="istickedoff">badCase a b = </span> +<span class="lineno"> 38 </span><span class="spaces"> </span><span class="istickedoff">if a > 100 </span> +<span class="lineno"> 39 </span><span class="spaces"> </span><span class="istickedoff">then error "badCase" </span> +<span class="lineno"> 40 </span><span class="spaces"> </span><span class="istickedoff">else if <span class="tickonlyfalse">a > 1000</span> </span> +<span class="lineno"> 41 </span><span class="spaces"> </span><span class="istickedoff">then <span class="nottickedoff">1</span> </span> +<span class="lineno"> 42 </span><span class="spaces"> </span><span class="istickedoff">else badCase (a + 1) <span class="nottickedoff">(b - 1)</span></span></span> +<span class="lineno"> 43 </span> +<span class="lineno"> 44 </span> +<span class="lineno"> 45 </span><span class="decl"><span class="istickedoff">foo2 = (1,2, if <span class="tickonlytrue">True</span> then 3 else <span class="nottickedoff">4</span>)</span></span> +<span class="lineno"> 46 </span> +<span class="lineno"> 47 </span><span class="decl"><span class="istickedoff">otherwoz = True</span></span> + +</pre> +</body> +</html> +Writing: hpc_index.html +<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; } +td.bar { background-color: #60de51; } +td.invbar { background-color: #f25913; } +table.dashboard { border-collapse: collapse ; border: solid 1px black } +.dashboard td { border: solid 1px black } +.dashboard th { border: solid 1px black } +</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td>  <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left">  Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_fun.html +<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; } +td.bar { background-color: #60de51; } +td.invbar { background-color: #f25913; } +table.dashboard { border-collapse: collapse ; border: solid 1px black } +.dashboard td { border: solid 1px black } +.dashboard th { border: solid 1px black } +</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td>  <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left">  Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_alt.html +<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; } +td.bar { background-color: #60de51; } +td.invbar { background-color: #f25913; } +table.dashboard { border-collapse: collapse ; border: solid 1px black } +.dashboard td { border: solid 1px black } +.dashboard th { border: solid 1px black } +</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td>  <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left">  Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html>Writing: hpc_index_exp.html +<html><head><meta http-equiv="Content-Type" content="text/html; charset=UTF-8"><style type="text/css">table.bar { background-color: #f25913; } +td.bar { background-color: #60de51; } +td.invbar { background-color: #f25913; } +table.dashboard { border-collapse: collapse ; border: solid 1px black } +.dashboard td { border: solid 1px black } +.dashboard th { border: solid 1px black } +</style></head><body><table class="dashboard" width="100%" border="1"><tr><th rowspan="2"><a href="hpc_index.html">module</a></th><th colspan="3"><a href="hpc_index_fun.html">Top Level Definitions</a></th><th colspan="3"><a href="hpc_index_alt.html">Alternatives</a></th><th colspan="3"><a href="hpc_index_exp.html">Expressions</a></th></tr><tr><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th><th>%</th><th colspan="2">covered / total</th></tr><tr><td>  <code>module <a href="Main.hs.html">Main</a></code></td><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr><tr></tr><tr style="background: #e0e0e0"><th align="left">  Program Coverage Total</th><td align="right">83%</td><td>5/6</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="83%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">58%</td><td>7/12</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="58%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td><td align="right">73%</td><td>73/100</td><td width="100"><table cellpadding="0" cellspacing="0" width="100%" class="bar"><tr><td><table cellpadding="0" cellspacing="0" width="73%"><tr><td height="12" class="bar"></td></tr></table></td></tr></table></td></tr></table></body></html> ===================================== testsuite/tests/hpc/function2/test.T ===================================== @@ -14,3 +14,14 @@ test('tough2', omit_ways(ghci_ways + prof_ways), # profile goes in the wrong place when(arch('wasm32'), fragile(23243)) ], multimod_compile_and_run, ['subdir/tough2.lhs', '-fhpc']) + +# Same as tough2, but for ghci +test('tough3', + [extra_files(['../hpcrun.pl', 'subdir/']), + literate, + cmd_prefix(hpc_prefix), + ignore_extension, + extra_hc_opts('-fhpc subdir/tough2.lhs'), + omit_ways(ghci_ways + prof_ways), # profile goes in the wrong place + when(arch('wasm32'), fragile(23243)) ], + ghci_script, ['tough3.script']) ===================================== testsuite/tests/hpc/function2/tough3.script ===================================== @@ -0,0 +1,2 @@ +:main +:quit ===================================== testsuite/tests/hpc/ghc_ghci/Makefile ===================================== @@ -9,7 +9,7 @@ hpc_ghc_ghci: hpc_ghc_ghci_bytecode: rm -f ./*.tix - printf "main\n:quit\n" | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -fhpc -fbyte-code-and-object-code -fprefer-byte-code BytecodeMain.hs + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) -fhpc -fbyte-code-and-object-code -fprefer-byte-code BytecodeMain.hs -e "main" -e ":quit" @[ -f .hpc/Main.mix ] || (echo "ERROR: Expected .hpc/Main.mix file not found"; exit 1) @set -- ./*.tix; [ -f "$$1" ] || (echo "ERROR: Expected .tix file not found"; exit 1); '$(HPC)' report "$$1" Main > hpc-report.txt @grep -F "100% expressions used" hpc-report.txt >/dev/null || (echo "ERROR: Expected full expression coverage in hpc report"; cat hpc-report.txt; exit 1) ===================================== testsuite/tests/hpc/hpcrun.pl ===================================== @@ -4,11 +4,12 @@ while($ARGV[0] =~ /^--/) { $arg = shift @ARGV; + last if ($arg eq '--'); if ($arg =~ /--hpc=(.*)/) { $HPC = $1; - } + } elsif ($arg =~ /--clear/) { - $CLEAR = 1; + $CLEAR = 1; } elsif ($arg =~ /--exeext=(.*)/) { $exeext = $1; @@ -19,8 +20,10 @@ while($ARGV[0] =~ /^--/) { } die "no option --hpc=* provided\n" if (!defined($HPC)); - -$binary = $ARGV[0] . $exeext; + +# Skip over any KEY=VALUE env assignments to find the real executable +my $exe = (grep { !/^\w+=/ } @ARGV)[0]; +$binary = $exe . $exeext; # get the basename: needed for the test function/subdir/tough2 $binary =~ s/^.*\/([^\/]*)$/$1/; @@ -38,7 +41,7 @@ while(<MARKUP>) { my $line = $_; print $line; if (/Writing: (\S+.html)/) { - system("cat $1"); + system("cat $1"); } } print "\n\n"; ===================================== testsuite/tests/hpc/simple/Makefile ===================================== @@ -2,3 +2,12 @@ TOP=../../.. include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk +hpc002: + "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) hpc002.hs -fhpc -v0 -e ":main" + "$(HPC)" report ghc + "$(HPC)" report ghc --per-module + LANG=ASCII "$(HPC)" markup ghc + +hpc003: + "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(TEST_HC_ARGS) -fhpc -v0 < hpc003.script + "$(HPC)" report ghc || echo "Can't summarise file that is ':load'ed" ===================================== testsuite/tests/hpc/simple/hpc002.hs ===================================== @@ -0,0 +1 @@ +main = print (const "Hello" "World") ===================================== testsuite/tests/hpc/simple/hpc002.stdout ===================================== @@ -0,0 +1,23 @@ +"Hello" + 75% expressions used (3/4) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +-----<module Main>----- + 75% expressions used (3/4) +100% boolean coverage (0/0) + 100% guards (0/0) + 100% 'if' conditions (0/0) + 100% qualifiers (0/0) +100% alternatives used (0/0) +100% local declarations used (0/0) +100% top-level declarations used (1/1) +Writing: Main.hs.html +Writing: hpc_index.html +Writing: hpc_index_fun.html +Writing: hpc_index_alt.html +Writing: hpc_index_exp.html ===================================== testsuite/tests/hpc/simple/hpc003.hs ===================================== @@ -0,0 +1 @@ +main = print (const "Hello" "World") ===================================== testsuite/tests/hpc/simple/hpc003.script ===================================== @@ -0,0 +1,2 @@ +:load hpc003.hs +:main ===================================== testsuite/tests/hpc/simple/hpc003.stderr ===================================== @@ -0,0 +1,7 @@ +hpc: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +can not find interactivezmsession_Main in ./.hpc + +HasCallStack backtrace: + error, called at libraries/hpc/Trace/Hpc/Mix.hs:110:15 in hpc-0.7.0.2-inplace:Trace.Hpc.Mix + ===================================== testsuite/tests/hpc/simple/hpc003.stdout ===================================== @@ -0,0 +1,2 @@ +"Hello" +Can't summarise file that is ':load'ed ===================================== testsuite/tests/hpc/simple/test.T ===================================== @@ -7,3 +7,16 @@ test('hpc001', [extra_files(['../hpcrun.pl']), cmd_prefix(hpc_prefix), ignore_extension ], compile_and_run, ['-fhpc']) + +test('hpc002', + [ when(arch('wasm32'), fragile(23243)) + , ignore_extension + ], + makefile_test, []) + +test('hpc003', + [ when(arch('wasm32'), fragile(23243)) + , ignore_extension + , extra_files(['hpc003.script']) + ], + makefile_test, []) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dca9e69945e98dbd1452067100dadb8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dca9e69945e98dbd1452067100dadb8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: driver: recognise .dyn_o as a valid object file to link if passed on the command line.
by Marge Bot (＠marge-bot) 03 Apr '26

03 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 9a1fe58d by Zubin Duggal at 2026-04-03T02:18:11-04:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 - - - - - 563b2788 by Simon Jakobi at 2026-04-03T02:18:12-04:00 Add regression test for #16145 Closes #16145. - - - - - 18c2e38d by Matthew Pickering at 2026-04-03T02:18:14-04:00 bytecode: Add magic header/version to bytecode files In order to avoid confusing errors when using stale interface files (ie from an older compiler version), we add a simple header/version check like the one for interface files. Fixes #27068 - - - - - 9211ccf1 by fendor at 2026-04-03T02:18:14-04:00 Add constants for bytecode in-memory buffer size Introduce a common constant for the default size of the .gbc and .bytecodelib binary buffer. The buffer is by default set to 1 MB. - - - - - a5f335f6 by Duncan Coutts at 2026-04-03T02:18:14-04:00 Add a rts posix FdWakup utility module This will be used to implement wakeupIOManager for in-RTS I/O managers. It provides a notification/wakeup mechanism using FDs, suitable for situations when a thread is blocked on a set of fds anyway. It uses the classic self-pipe trick, or equivalently eventfd on supported platforms. This will initially be used to implement prompt interrupt or shutdown of the posix ticker thread. - - - - - 094f22ba by Duncan Coutts at 2026-04-03T02:18:15-04:00 Add prompt shutdown to the pthread ticker implementation. The Linux timerfd ticker monitors a pipe which is used by exitTicker to ensure a prompt wakeup and shutdown. The pthread ticker lacked this and so would only exit at the next ticker wakeup (10ms by default). This patch adds the same mechanism to the pthread ticker. This changes the pthread ticker from waiting by using nanosleep() to waiting using either ppoll() or select(), so that it can wait on both a time and a file descriptor. On Linux at least, a test program to compare the timing jitter of these APIs shows that using nanpsleep, ppoll or select makes no statistical difference to the maximum or average jitter. This is a step towards unifying the posix ticker implementations, so that we can have just one portable one (albeit with some limited cpp). It is also a step towards using the ticker as part of a more general implementation of wakeUpRts, since this will require a method to wake the rts from a signal handler context (ctl-c handler). - - - - - d2c780a3 by Duncan Coutts at 2026-04-03T02:18:15-04:00 Update ticker header commentary It was antique and didn't apply even to the previous implementation, and certainly not to the updated one. - - - - - 69b6033c by Duncan Coutts at 2026-04-03T02:18:15-04:00 Remove the timerfd-based ticker implementation There does not appear to be any remaining advantage on Linux to using the timerfd ticker implementation over the portable one (using ppoll on Linux for precise timing). The eventfd implementation was originally added at a time when Linux was still using a signal based implementation. So it made sense at the time. See (closed) issue #10840. - - - - - 5c32c5fb by Duncan Coutts at 2026-04-03T02:18:15-04:00 Consolidate to a single posix ticker implementation Previously we had four implementations, two using signals and two using threads. Having just one should make behaviour more consistent between platforms, and should make maintenance easier. - - - - - c222aa0b by mangoiv at 2026-04-03T02:18:16-04:00 testsuite: filter stderr for static001 on darwin This reactivates the test on x86_64 darwin as this should have been done long ago and ignores warnings emitted by ranlib on newer version of the darwin toolchain since they are benign. (no symbols for stub libraries) Fixes #27116 - - - - - 9cdb57b6 by mangoiv at 2026-04-03T02:18:17-04:00 issue template: fix add bug label - - - - - ebb20c2c by Sylvain Henry at 2026-04-03T02:18:41-04:00 Add more canned GC functions for common register patterns (#27142) Based on analysis of heap-check sites across the GHC compiler and Cabal, the following patterns were not covered by existing canned GC functions but occurred frequently enough to warrant specialisation: stg_gc_ppppp -- 5 GC pointers stg_gc_ip -- unboxed word + GC pointer stg_gc_pi -- GC pointer + unboxed word stg_gc_ii -- two unboxed words stg_gc_bpp -- byte (I8) + two GC pointers Adding these reduces the fraction of heap-check sites falling back to the generic GC path from ~1.4% to ~0.4% when compiling GHC itself. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 30 changed files: - .gitlab/issue_templates/default.md - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/StgToCmm/Heap.hs - rts/HeapStackCheck.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - + rts/posix/FdWakeup.c - + rts/posix/FdWakeup.h - rts/posix/Ticker.c - − rts/posix/ticker/Pthread.c - − rts/posix/ticker/TimerFd.c - rts/rts.cabal - testsuite/driver/testlib.py - testsuite/tests/driver/all.T - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - testsuite/tests/runghc/Makefile - + testsuite/tests/runghc/T16145.hs - + testsuite/tests/runghc/T16145.stdout - + testsuite/tests/runghc/T16145_aux.hs - testsuite/tests/runghc/all.T Changes: ===================================== .gitlab/issue_templates/default.md ===================================== @@ -20,5 +20,5 @@ Optional: * System Architecture: -/label ~bug +/label ~"T::bug" /label ~"needs triage" ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -25,22 +25,26 @@ where import GHC.Prelude import GHC.ByteCode.Binary -import GHC.ByteCode.Types import GHC.ByteCode.Recomp.Binary (computeFingerprint) -import GHC.Driver.Env +import GHC.ByteCode.Types import GHC.Driver.DynFlags +import GHC.Driver.Env import GHC.Iface.Binary import GHC.Iface.Recomp.Binary (putNameLiterally) import GHC.Linker.Types +import GHC.Settings.Constants (hiVersion) import GHC.Unit.Types import GHC.Utils.Binary -import GHC.Utils.TmpFs -import GHC.Utils.Logger import GHC.Utils.Fingerprint (Fingerprint) +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.TmpFs import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS +import Data.Char (ord) import Data.Traversable +import Data.Word import System.Directory import System.FilePath @@ -79,21 +83,35 @@ The ticket where bytecode objects were dicussed is #26298 See Note [-fwrite-byte-code is not the default] See Note [Recompilation avoidance with bytecode objects] +See Note [Persistent bytecode file headers] +Note [Persistent bytecode file headers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Persistent bytecode files (`.gbc`) and bytecode libraries (`.bytecodelib`) +are version-specific binary formats. Without a small file-level header, stale +or corrupt files are only discovered once we start deserialising the payload, +which can lead to confusing failures. + +To make these failures explicit, we write a file-kind-specific magic word and +the current `hiVersion` ahead of the binary payload. Readers validate this +header before setting up the normal `Name`/`FastString` deserialisation +machinery. This follows the same approach as normal interface files. -} writeBytecodeLib :: BytecodeLib -> FilePath -> IO () writeBytecodeLib lib path = do odbco <- encodeBytecodeLib lib createDirectoryIfMissing True (takeDirectory path) - bh' <- openBinMem (1024 * 1024) + bh' <- openBinMem initBinMemSize bh <- addBinNameWriter bh' + writePersistentBytecodeHeader BytecodeLibraryFile bh putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh path readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib readBytecodeLib hsc_env path = do bh' <- readBinMem path + readPersistentBytecodeHeader BytecodeLibraryFile path bh' bh <- addBinNameReader (hsc_NC hsc_env) bh' res <- getWithUserData (hsc_NC hsc_env) bh pure res @@ -185,6 +203,7 @@ readBinByteCode hsc_env f = do readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode readOnDiskModuleByteCode hsc_env f = do bh' <- readBinMem f + readPersistentBytecodeHeader ModuleByteCodeFile f bh' bh <- addBinNameReader (hsc_NC hsc_env) bh' getWithUserData (hsc_NC hsc_env) bh @@ -192,9 +211,10 @@ readOnDiskModuleByteCode hsc_env f = do writeBinByteCode :: FilePath -> ModuleByteCode -> IO () writeBinByteCode f cbc = do createDirectoryIfMissing True (takeDirectory f) - bh' <- openBinMem (1024 * 1024) + bh' <- openBinMem initBinMemSize bh <- addBinNameWriter bh' odbco <- encodeOnDiskModuleByteCode cbc + writePersistentBytecodeHeader ModuleByteCodeFile bh putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh f @@ -213,3 +233,64 @@ fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> fingerprintModuleByteCodeContents modl cbc foreign_files = do foreign_contents <- readObjectFiles foreign_files pure $ computeFingerprint putNameLiterally (modl, cbc, foreign_contents) + +-- ---------------------------------------------------------------------------- +-- ByteCode module and library magic header. +-- ---------------------------------------------------------------------------- + +data PersistentBytecodeFile + = ModuleByteCodeFile + | BytecodeLibraryFile + +-- See Note [Persistent bytecode file headers] +writePersistentBytecodeHeader :: PersistentBytecodeFile -> WriteBinHandle -> IO () +writePersistentBytecodeHeader file_kind bh = do + put_ bh (persistentBytecodeMagic file_kind) + put_ bh (show hiVersion) + +readPersistentBytecodeHeader :: PersistentBytecodeFile -> FilePath -> ReadBinHandle -> IO () +readPersistentBytecodeHeader file_kind path bh = do + let mismatch what expected actual = + throwGhcExceptionIO $ ProgramError $ + persistentBytecodeFileDescription file_kind ++ " header mismatch in " ++ path ++ + ": " ++ what ++ " (expected " ++ expected ++ ", got " ++ actual ++ ")" + + magic <- get bh + let expected_magic = persistentBytecodeMagic file_kind + if unFixedLength magic == unFixedLength expected_magic + then pure () + else mismatch "magic" (show $ unFixedLength expected_magic) (show $ unFixedLength magic) + + version <- get bh + let expected_version = show hiVersion + if version == expected_version + then pure () + else mismatch "version" expected_version version + +persistentBytecodeFileDescription :: PersistentBytecodeFile -> String +persistentBytecodeFileDescription ModuleByteCodeFile = "bytecode file" +persistentBytecodeFileDescription BytecodeLibraryFile = "bytecode library" + +persistentBytecodeMagic :: PersistentBytecodeFile -> FixedLengthEncoding Word32 +persistentBytecodeMagic file_kind = + case file_kind of + ModuleByteCodeFile -> asciiWord32 "gbc0" + BytecodeLibraryFile -> asciiWord32 "bcl0" + +-- | Encode a 4-letter word into a single Word32. +asciiWord32 :: String -> FixedLengthEncoding Word32 +asciiWord32 [a, b, c, d] = + FixedLengthEncoding $ + (fromIntegral (ord a) `shiftL` 24) .|. + (fromIntegral (ord b) `shiftL` 16) .|. + (fromIntegral (ord c) `shiftL` 8) .|. + fromIntegral (ord d) +asciiWord32 _ = error "asciiWord32: expected exactly four ASCII characters" + +-- ---------------------------------------------------------------------------- +-- Constants and utils +-- ---------------------------------------------------------------------------- + +-- | Initial ram buffer to allocate for writing .gbc and .bytecodelib files. +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 -- 1 MB ===================================== compiler/GHC/Driver/Phases.hs ===================================== @@ -262,7 +262,7 @@ objish_suffixes :: Platform -> [String] -- the GHC-compiled code will run objish_suffixes platform = case platformOS platform of OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] - _ -> [ "o" ] + _ -> [ "o", "dyn_o"] dynlib_suffixes :: Platform -> [String] dynlib_suffixes platform = case platformOS platform of ===================================== compiler/GHC/StgToCmm/Heap.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions @@ -44,7 +45,7 @@ import GHC.Types.Id ( Id ) import GHC.Unit import GHC.Platform import GHC.Platform.Profile -import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Data.FastString( FastString ) import GHC.Utils.Panic( sorry ) import Control.Monad (when) @@ -125,7 +126,7 @@ allocHeapClosure rep info_ptr use_cc payload = do -- ie 1 *before* the info-ptr word of new object. base <- getHpRelOffset info_offset - emitComment $ mkFastString "allocHeapClosure" + emitComment "allocHeapClosure" emitSetDynHdr base info_ptr use_cc -- Fill in the fields @@ -460,35 +461,41 @@ genericGC checkYield code call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] heapCheck False checkYield (call <*> mkBranch lretry) code +-- | Predefined ("canned") GC functions +-- +-- Functions have been added to cover 99% of the GC calls made in GHC and Cabal. +-- See #27142. cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint platform regs - = case map localRegType regs of - [] -> Just (mkGcLabel "stg_gc_noregs") - [ty] - | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") - | isFloatType ty -> case width of - W32 -> Just (mkGcLabel "stg_gc_f1") - W64 -> Just (mkGcLabel "stg_gc_d1") - _ -> Nothing - - | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing - where - width = typeWidth ty - [ty1,ty2] - | isGcPtrType ty1 - && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") - [ty1,ty2,ty3] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") - [ty1,ty2,ty3,ty4] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 - && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") - _otherwise -> Nothing +cannedGCEntryPoint platform regs = + case map localRegType regs of + [] -> ret "stg_gc_noregs" + [ty] + | is_gc ty -> ret "stg_gc_unpt_r1" + | is_f32 ty -> ret "stg_gc_f1" + | is_f64 ty -> ret "stg_gc_d1" + | is_wn ty -> ret "stg_gc_unbx_r1" + | is_w64 ty -> ret "stg_gc_l1" + [ty1,ty2] + | is_gc ty1 && is_gc ty2 -> ret "stg_gc_pp" + | is_gc ty1 && is_wn ty2 -> ret "stg_gc_pi" + | is_wn ty1 && is_gc ty2 -> ret "stg_gc_ip" + | is_wn ty1 && is_wn ty2 -> ret "stg_gc_ii" + [ty1,ty2,ty3] + | is_gc ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_ppp" + | is_w8 ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_bpp" + [ty1,ty2,ty3,ty4] + | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 -> ret "stg_gc_pppp" + [ty1,ty2,ty3,ty4,ty5] + | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 && is_gc ty5 -> ret "stg_gc_ppppp" + _ -> Nothing + where + ret fs = Just (mkGcLabel fs) + is_gc ty = isGcPtrType ty + is_wn ty = isBitsType ty && typeWidth ty == wordWidth platform + is_w8 ty = isBitsType ty && typeWidth ty == W8 + is_w64 ty = isBitsType ty && typeWidth ty == W64 + is_f32 ty = isFloatType ty && typeWidth ty == W32 + is_f64 ty = isFloatType ty && typeWidth ty == W64 -- Note [stg_gc arguments] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -514,8 +521,8 @@ generic_gc :: CmmExpr generic_gc = mkGcLabel "stg_gc_noregs" -- | Create a CLabel for calling a garbage collector entry point -mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s))) +mkGcLabel :: FastString -> CmmExpr +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId s)) ------------------------------- heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a ===================================== rts/HeapStackCheck.cmm ===================================== @@ -373,8 +373,6 @@ stg_gc_l1 return (L_ l) jump stg_gc_noregs (stg_ret_l_info, l) (); } -/*-- Unboxed tuples with multiple pointers -------------------------------- */ - stg_gc_pp return (P_ arg1, P_ arg2) { call stg_gc_noregs(); @@ -393,6 +391,36 @@ stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4) return (arg1,arg2,arg3,arg4); } +stg_gc_ppppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4, P_ arg5) +{ + call stg_gc_noregs(); + return (arg1,arg2,arg3,arg4,arg5); +} + +stg_gc_ip return (W_ arg1, P_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_pi return (P_ arg1, W_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_ii return (W_ arg1, W_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_bpp return (I8 arg1, P_ arg2, P_ arg3) +{ + call stg_gc_noregs(); + return (arg1,arg2,arg3); +} + /* ----------------------------------------------------------------------------- Generic function entry heap check code. ===================================== rts/RtsSymbols.c ===================================== @@ -499,6 +499,11 @@ extern char **environ; SymI_HasDataProto(stg_gc_pp) \ SymI_HasDataProto(stg_gc_ppp) \ SymI_HasDataProto(stg_gc_pppp) \ + SymI_HasDataProto(stg_gc_ppppp) \ + SymI_HasDataProto(stg_gc_ip) \ + SymI_HasDataProto(stg_gc_pi) \ + SymI_HasDataProto(stg_gc_ii) \ + SymI_HasDataProto(stg_gc_bpp) \ SymI_HasDataProto(__stg_gc_fun) \ SymI_HasDataProto(stg_gc_fun_info) \ SymI_HasDataProto(stg_yield_noregs) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -361,6 +361,11 @@ RTS_FUN_DECL(stg_gc_l1); RTS_FUN_DECL(stg_gc_pp); RTS_FUN_DECL(stg_gc_ppp); RTS_FUN_DECL(stg_gc_pppp); +RTS_FUN_DECL(stg_gc_ppppp); +RTS_FUN_DECL(stg_gc_ip); +RTS_FUN_DECL(stg_gc_pi); +RTS_FUN_DECL(stg_gc_ii); +RTS_FUN_DECL(stg_gc_bpp); RTS_RET(stg_gc_fun); RTS_FUN_DECL(__stg_gc_fun); ===================================== rts/posix/FdWakeup.c ===================================== @@ -0,0 +1,141 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * This is used to provide a mechanism to wake a thread when it is blocked + * waiting on fds and timeouts. The mechanism works by including the read end + * fd into the set of fds the thread waits on, and when a wake up is needed, + * the write end fd is used. + * + * This is implemented using either eventfd() or pipe(). + * + * Linux 2.6.22+ and FreeBSD 13+ support eventfd. It is a single fd with a + * 64bit counter. It uses fewer resources than a pipe (less memory and one + * rather than two fds), and is a tad faster (on the order of 5-10%). Using + * write() adds to the counter, while read() reads and resets it. Thus + * multiple writes are combined automatically into a single corresponding + * read. + * + * Otherwise we use a classic unix pipe. + * + * In both implementations, multiple sendFdWakeup notifcations (without + * interleaved collectFdWakeup) are combined to a single notification. This + * is automatic given the semantics of eventfd, while for pipe we implement + * it explicitly by draining the pipe in collectFdWakeup. + * + * -------------------------------------------------------------------------*/ + +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "FdWakeup.h" + +#include <fcntl.h> +#include <unistd.h> + +#ifdef HAVE_SYS_EVENTFD_H +#include <sys/eventfd.h> +#endif + +#if !defined(HAVE_EVENTFD) \ + || (defined(HAVE_EVENTFD) && !(defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK))) +static void fcntl_CLOEXEC_NONBLOCK(int fd) +{ + int res1 = fcntl(fd, F_SETFD, FD_CLOEXEC); + int res2 = fcntl(fd, F_SETFL, O_NONBLOCK); + if (RTS_UNLIKELY(res1 < 0 || res2 < 0)) { + sysErrorBelch("newFdWakeup fcntl()"); + stg_exit(EXIT_FAILURE); + } +} +#endif + +void newFdWakeup(int *wakeup_fd_r, int *wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + int wakeup_fd; +#if defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK) + wakeup_fd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); +#else + wakeup_fd = eventfd(0, 0); + if (wakeup_fd >= 0) fcntl_CLOEXEC_NONBLOCK(wakeup_fd); +#endif + if (RTS_UNLIKELY(wakeup_fd < 0)) { + sysErrorBelch("newFdWakeup eventfd()"); + stg_exit(EXIT_FAILURE); + } + /* eventfd uses the same fd for each end */ + *wakeup_fd_r = wakeup_fd; + *wakeup_fd_w = wakeup_fd; +#else + int pipefd[2]; + int res; + res = pipe(pipefd); + if (RTS_UNLIKELY(res < 0)) { + sysErrorBelch("newFdWakeup pipe"); + stg_exit(EXIT_FAILURE); + } + fcntl_CLOEXEC_NONBLOCK(pipefd[0]); + fcntl_CLOEXEC_NONBLOCK(pipefd[1]); + *wakeup_fd_r = pipefd[0]; /* read end */ + *wakeup_fd_w = pipefd[1]; /* write end */ +#endif +} + +void closeFdWakeup(int wakeup_fd_r, int wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + ASSERT(wakeup_fd_r == wakeup_fd_w); + close(wakeup_fd_r); +#else + ASSERT(wakeup_fd_r != wakeup_fd_w); + close(wakeup_fd_r); + close(wakeup_fd_w); +#endif +} + +/* This is safe to use from a signal handler. Using write() to a pipe + * or eventfd is fine. */ +void sendFdWakeup(int wakeup_fd_w) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t val = 1; + res = write(wakeup_fd_w, &val, 8); +#else + unsigned char buf = 1; + res = write(wakeup_fd_w, &buf, 1); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* Unlikely the pipe buffer will fill, but it would not be an error. */ + if (errno == EAGAIN) return; + sysErrorBelch("sendFdWakeup write"); + stg_exit(EXIT_FAILURE); + } +} + +void collectFdWakeup(int wakeup_fd_r) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t buf; + /* eventfd combines events into one counter, so a single read is enough */ + res = read(wakeup_fd_r, &buf, 8); +#else + /* Drain the pipe buffer. Multiple wakeup notifications could + * have been sent before we have a chance to collect them. + */ + uint64_t buf; + do { + res = read(wakeup_fd_r, &buf, 8); + } while (res == 8); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* After the first pipe read, it could block */ + if (errno == EAGAIN) return; + sysErrorBelch("collectFdWakeup read"); + stg_exit(EXIT_FAILURE); + } +} ===================================== rts/posix/FdWakeup.h ===================================== @@ -0,0 +1,40 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * It provides a mechanism for a thread that block on fds to add a simple + * wakeup/notification feature. + * + * Start with newFdWakeup, and pass the fd_r to the thread that needs the + * wakeup feature. The thread that needs to be woken should include the fd_r + * into the set of fds that the thread waits on (e.g. using poll or similar). + * If this fd becomes ready for read, the thread must call collectFdWakeup, + * and when a wake up is needed, the write end fd is used. In any other thread + * (or in a signal handler), call sendFdWakeup(fd_w) to (asynchronously) cause + * the wakeup. + * + * There is no message payload. Multiple wakeups may be combined (if they're + * sent multiple times before the notified thread can wake and call + * collectFdWakeup). + * + * The implementation uses pipe() or eventfd() on supported OSs. + * + * Prototypes for functions in FdWakeup.c + * + * -------------------------------------------------------------------------*/ + +#pragma once + +#include "BeginPrivate.h" + +void newFdWakeup(int *fd_r, int *fd_w); +void closeFdWakeup(int fd_r, int fd_w); + +/* This is safe to use from a signal handler */ +void sendFdWakeup(int fd_w); +void collectFdWakeup(int fd_r); + +#include "EndPrivate.h" + ===================================== rts/posix/Ticker.c ===================================== @@ -1,19 +1,53 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1995-2007 + * (c) The GHC Team, 1995-2026 * - * Posix implementation(s) of the interval timer for profiling and pre-emptive - * scheduling. + * The posix implementation of the interval timer, used for pre-emptive + * scheduling of Haskell threads, and for sample based profiling. + * + * This file defines the "ticker": the platform-specific service to install and + * run the timer. See rts/Timer.c for the platform-dependent view of interval + * timing. * * ---------------------------------------------------------------------------*/ -/* The interval timer is used for profiling and for context switching. - * This file defines the platform-specific services to install and run the - * timers, and we call this the ticker. See rts/Timer.c for the - * platform-dependent view of interval timing. +/* This implementation uses a posix thread which repeatedly blocks on a timeout + * using either the ppoll() or select() API. This lets it also block on a file + * descriptor for early wakeup. + * + * The design uses a simple relative time delay with no catchup. That is, time + * spent by the ticker thread itself (e.g. flushing eventlog buffers) is not + * accounted for, and the next tick is delayed by that much (modulo wakeup + * jitter). This is probably the right thing to do: generally in realtime + * systems one does not want to try to catch up when behind, since that tends + * towards oversubscribing resources. Graceful degredation is usually + * preferable. + * + * Experimental results (on Linux 6.18 on x86-64) to measure the typical + * difference between the requested wakeup time and actual wakeup time for + * different delay intervals: + * + * interval typical actual wakeup time after due time + * 10000us 340 -- 400us (this is the default interval) + * 1000us 55 -- 100us + * 100us 55us + * 10us 55us + * + * While there's quite a bit of variance to these numbers, the results do not + * vary significantly between using select, ppoll or nanosleep. + * + * On Linux at least, for longer delays the kernel allows itself lower wakeup + * accuracy (which allows it to save power by coalescing multiple wakeups). + * Similarly, the reason for 55us on the low end is that the default thread + * timer slack on Linux is 50us, and context switch time accounts for the + * remainder. + * + * In conclusion, on Linux at least, the accuracy is fine, both for the + * default interval (10ms, 10000us) and for shorter intervals used during + * profiling. * * Historically we had ticker implementations using signals. This was always a - * rather shakey thing to do but we had few alternatives. + * rather shakey thing to do but we originally had few alternatives. * - One problem with using signals is that there are severe limits on what * code can be called from signal handlers. In particular it's not possible * to take locks in a signal handler contex. This was enough for contex @@ -23,17 +57,245 @@ * calls (#10840) or can be overwritten by user code. */ -/* Select a ticker implementation to use: - * - * On modern Linux, FreeBSD and NetBSD we can use timerfd_create and a thread - * that waits on it using poll. Linux has had timerfd since version 2.6.25. - * NetBSD has had timerfd since version 10, and FreeBSD since version 15. - * - * For older version of linux/bsd without timerfd, and for all other posix - * platforms, we use the implementation using posix pthreads and nanosleep(). +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "Ticker.h" +#include "RtsUtils.h" +#include "Proftimer.h" +#include "Schedule.h" +#include "posix/Clock.h" +#include "posix/FdWakeup.h" + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 +/* We prefer the ppoll() function if available since it allows sanely waiting + * on a single fd with precise timeouts (nanosecond precision). It is not in + * the posix standard however and some platforms (notably glibc and freebsd) + * need special CPP defines to make it available: + */ +#define _GNU_SOURCE 1 +#define __BSD_VISIBLE 1 +#include <signal.h> +#include <poll.h> +#else +/* Otherwise we use the classic select(), which does have microsecond + * precision, but requires we build three whole 1024 bit (128 byte) fd sets + * just to wait on one fd. */ -#if defined(HAVE_SYS_TIMERFD_H) -#include "ticker/TimerFd.c" +#include <sys/select.h> +#endif + +#include <time.h> +#if HAVE_SYS_TIME_H +# include <sys/time.h> +#endif + +#if defined(HAVE_SIGNAL_H) +# include <signal.h> +#endif + +#include <string.h> + +#include <pthread.h> +#if defined(HAVE_PTHREAD_NP_H) +#include <pthread_np.h> +#endif +#include <unistd.h> +#include <fcntl.h> + +static Time itimer_interval = DEFAULT_TICK_INTERVAL; + +// Should we be firing ticks? +// Writers to this must hold the mutex below. +static bool stopped = false; + +// should the ticker thread exit? +// This can be set without holding the mutex. +static bool exited = true; + +// Signaled when we want to (re)start the timer +static Condition start_cond; +static Mutex mutex; +static OSThreadId thread; + +// fds for interrupting the ticker +static int interruptfd_r = -1, interruptfd_w = -1; + +static void *itimer_thread_func(void *_handle_tick) +{ + TickProc handle_tick = _handle_tick; + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + struct pollfd pollfds[1]; + + pollfds[0].fd = interruptfd_r; + pollfds[0].events = POLLIN; + + struct timespec ts = { .tv_sec = TimeToSeconds(itimer_interval) + , .tv_nsec = TimeToNS(itimer_interval) % 1000000000 + }; #else -#include "ticker/Pthread.c" + fd_set selectfds; + FD_ZERO(&selectfds); + FD_SET(interruptfd_r, &selectfds); + + struct timeval tv = { .tv_sec = TimeToSeconds(itimer_interval) + /* convert remainder time in nanoseconds + to microseconds, rounding up: */ + , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000) + + 999) / 1000 + }; +#endif + + // Relaxed is sufficient: If we don't see that exited was set in one iteration we will + // see it next time. + while (!RELAXED_LOAD_ALWAYS(&exited)) { + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + int nfds = 1; + int nready = ppoll(pollfds, nfds, &ts, NULL); +#else + struct timeval tv_tmp = tv; // copy since select may change this value. + int nfds = interruptfd_r+1; + int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp); +#endif + // In either case (ppoll or select), the result nready is the number + // of fds that are ready. + if (RTS_LIKELY(nready == 0)) { + // Timer expired, not interrupted, continue. + } else if (nready > 0) { + // We only monitor one fd (the interruptfd_r), so we know + // it is that fd that is ready without any further checks. + collectFdWakeup(interruptfd_r); + // No further action needed, continue on to handling the final tick + // and then stop. + + // Note that we rely on sendFdWakeup and select/poll to provide the + // happens-before relation. So if 'exited' was set before calling + // sendFdWakeup, then we should be able to reliably read it after. + // And thus reading 'exited' in the while loop guard is ok. + } else { + // While the RTS attempts to mask signals, some foreign libraries + // that rely on signal delivery may unmask them. Consequently we + // may see EINTR. See #24610. + if (errno != EINTR) { + sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); + } + } + + // first try a cheap test + if (RELAXED_LOAD_ALWAYS(&stopped)) { + OS_ACQUIRE_LOCK(&mutex); + // should we really stop? + if (stopped) { + waitCondition(&start_cond, &mutex); + } + OS_RELEASE_LOCK(&mutex); + } else { + handle_tick(0); + } + } + + return NULL; +} + +void +initTicker (Time interval, TickProc handle_tick) +{ + itimer_interval = interval; + stopped = true; + exited = false; +#if defined(HAVE_SIGNAL_H) + sigset_t mask, omask; + int sigret; +#endif + int ret; + + initCondition(&start_cond); + initMutex(&mutex); + + /* Open the interrupt fd synchronously. + * + * We used to do it in itimer_thread_func (i.e. in the timer thread) but it + * meant that some user code could run before it and get confused by the + * allocation of the timerfd. + * + * See hClose002 which unsafely closes a file descriptor twice expecting an + * exception the second time: it sometimes failed when the second call to + * "close" closed our own timerfd which inadvertently reused the same file + * descriptor closed by the first call! (see #20618) + */ + + if (interruptfd_r != -1) { + // don't leak the old file descriptors after a fork (#25280) + closeFdWakeup(interruptfd_r, interruptfd_w); + } + newFdWakeup(&interruptfd_r, &interruptfd_w); + + /* + * Create the thread with all blockable signals blocked, leaving signal + * handling to the main and/or other threads. This is especially useful in + * the non-threaded runtime, where applications might expect sigprocmask(2) + * to effectively block signals. + */ +#if defined(HAVE_SIGNAL_H) + sigfillset(&mask); + sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); +#endif + ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); +#if defined(HAVE_SIGNAL_H) + if (sigret == 0) + pthread_sigmask(SIG_SETMASK, &omask, NULL); #endif + + if (ret != 0) { + barf("Ticker: Failed to spawn thread: %s", strerror(errno)); + } +} + +void +startTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, false); + signalCondition(&start_cond); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +stopTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, true); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +exitTicker (bool wait) +{ + ASSERT(!SEQ_CST_LOAD(&exited)); + SEQ_CST_STORE(&exited, true); + // ensure that ticker wakes up if stopped + startTicker(); + sendFdWakeup(interruptfd_w); + + // wait for ticker to terminate if necessary + if (wait) { + if (pthread_join(thread, NULL)) { + sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); + } + closeFdWakeup(interruptfd_r, interruptfd_w); + closeMutex(&mutex); + closeCondition(&start_cond); + } else { + pthread_detach(thread); + } +} + +int +rtsTimerSignal(void) +{ + return SIGALRM; +} ===================================== rts/posix/ticker/Pthread.c deleted ===================================== @@ -1,195 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2007 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (rtsSleep(itimer_interval) != 0) { - sysErrorBelch("Ticker: sleep failed: %s", strerror(errno)); - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/posix/ticker/TimerFd.c deleted ===================================== @@ -1,291 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2023 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -#include <sys/timerfd.h> - - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -// file descriptor for the timer (Linux only) -static int timerfd = -1; - -// pipe for signaling exit -static int pipefds[2]; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - uint64_t nticks; - ssize_t r = 0; - struct pollfd pollfds[2]; - - pollfds[0].fd = pipefds[0]; - pollfds[0].events = POLLIN; - pollfds[1].fd = timerfd; - pollfds[1].events = POLLIN; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (poll(pollfds, 2, -1) == -1) { - // While the RTS attempts to mask signals, some foreign libraries - // may rely on signal delivery may unmask them. Consequently we may - // see EINTR. See #24610. - if (errno != EINTR) { - sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); - } - } - - // We check the pipe first, even though the timerfd may also have triggered. - if (pollfds[0].revents & POLLIN) { - // the pipe is ready for reading, the only possible reason is that we're exiting - exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value - // no further action needed, skip ahead to handling the final tick and then stopping - } - else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading - r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now - - if ((r == 0) && (errno == 0)) { - /* r == 0 is expected only for non-blocking fd (in which case - * errno should be EAGAIN) but we use a blocking fd. - * - * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335) - * on some platforms we could see r == 0 and errno == 0. - */ - IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it.")); - } - else if (r != sizeof(nticks) && errno != EINTR) { - barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r); - } - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - close(timerfd); - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* Open the file descriptor for the timer synchronously. - * - * We used to do it in itimer_thread_func (i.e. in the timer thread) but it - * meant that some user code could run before it and get confused by the - * allocation of the timerfd. - * - * See hClose002 which unsafely closes a file descriptor twice expecting an - * exception the second time: it sometimes failed when the second call to - * "close" closed our own timerfd which inadvertently reused the same file - * descriptor closed by the first call! (see #20618) - */ - struct itimerspec it; - it.it_value.tv_sec = TimeToSeconds(itimer_interval); - it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000; - it.it_interval = it.it_value; - - if (timerfd != -1) { - // don't leak the old file descriptors after a fork (#25280) - close(timerfd); - close(pipefds[0]); - close(pipefds[1]); - timerfd = -1; - } - - timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC); - if (timerfd == -1) { - barf("timerfd_create: %s", strerror(errno)); - } - if (!TFD_CLOEXEC) { - fcntl(timerfd, F_SETFD, FD_CLOEXEC); - } - if (timerfd_settime(timerfd, 0, &it, NULL)) { - barf("timerfd_settime: %s", strerror(errno)); - } - - if (pipe(pipefds) < 0) { - barf("pipe: %s", strerror(errno)); - } - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - // write anything to the pipe to trigger poll() in the ticker thread - if (write(pipefds[1], "stop", 5) < 0) { - sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno)); - } - - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - - // These need to happen AFTER the ticker thread has finished to prevent a race condition - // where the ticker thread closes the read end of the pipe before we're done writing to it. - close(pipefds[0]); - close(pipefds[1]); - - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/rts.cabal ===================================== @@ -582,11 +582,9 @@ library posix/Ticker.c posix/OSMem.c posix/OSThreads.c + posix/FdWakeup.c posix/Poll.c posix/Select.c posix/Signals.c posix/Timeout.c posix/TTY.c - -- ticker/*.c - -- We don't want to compile posix/ticker/*.c, these will be #included - -- from Ticker.c ===================================== testsuite/driver/testlib.py ===================================== @@ -3043,6 +3043,12 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 + if opsys('darwin'): + s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + return s # normalise a .prof file, so that we can reasonably compare it against ===================================== testsuite/tests/driver/all.T ===================================== @@ -120,9 +120,7 @@ if config.os == 'darwin': else: only_darwin = skip -test('static001', [extra_files(['Static001.hs']), - only_darwin, - when(arch('x86_64'), expect_broken(8127))], +test('static001', [extra_files(['Static001.hs']), only_darwin], makefile_test, ['static001']) test('dynHelloWorld', ===================================== testsuite/tests/driver/bytecode-object/Makefile ===================================== @@ -159,3 +159,9 @@ bytecode_object25: "$(TEST_HC)" $(TEST_HC_OPTS) -c BytecodeForeign.hs -fbyte-code -fwrite-byte-code -fwrite-interface $(ghciWayFlags) "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v1 -fno-hide-source-paths -fbyte-code -fwrite-byte-code -fwrite-interface BytecodeForeign.hs -e "testForeign" +# Test that corrupt bytecode file headers are rejected clearly. +bytecode_object26: + "$(TEST_HC)" $(TEST_HC_OPTS) -c BytecodeTest.hs -fbyte-code -fwrite-byte-code + @printf 'bad!' | dd of=BytecodeTest.gbc bs=1 count=4 conv=notrunc 2>/dev/null + ! "$(TEST_HC)" $(TEST_HC_OPTS) -c -bytecodelib -o linked.bytecode BytecodeTest.gbc 2> bytecode_object26.stderr + @grep -F "bytecode file header mismatch" bytecode_object26.stderr >/dev/null ===================================== testsuite/tests/driver/bytecode-object/all.T ===================================== @@ -26,3 +26,4 @@ test('bytecode_object22', bytecode_opts, makefile_test, ['bytecode_object22']) test('bytecode_object23', bytecode_opts, makefile_test, ['bytecode_object23']) test('bytecode_object24', bytecode_opts + [copy_files], makefile_test, ['bytecode_object24']) test('bytecode_object25', [bytecode_opts, req_interp, extra_files(['BytecodeForeign.hs', 'BytecodeForeign.c'])], makefile_test, ['bytecode_object25']) +test('bytecode_object26', [bytecode_opts], makefile_test, ['bytecode_object26']) ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -238,3 +238,10 @@ test-late-plugin: .PHONY: T21730 T21730: "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T21730.hs -package-db T21730-plugin/pkg.T21730-plugin/local.package.conf + +# Test that .dyn_o files are accepted as valid object files on the command line +# without producing "ignoring unrecognised input" warnings (#24486) +.PHONY: T24486 +T24486: + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c T24486_Helper.hs -osuf dyn_o + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T24486.hs T24486_Helper.dyn_o -package-db T24486-plugin/pkg.T24486-plugin/local.package.conf -fplugin T24486_Plugin -plugin-package T24486-plugin ===================================== testsuite/tests/plugins/T24486-plugin/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean.%: + rm -rf pkg.$* + +HERE := $(abspath .) +$(eval $(call canonicalise,HERE)) + +package.%: + $(MAKE) -s --no-print-directory clean.$* + mkdir pkg.$* + "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs + "$(GHC_PKG)" init pkg.$*/local.package.conf + pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) + pkg.$*/setup build --distdir pkg.$*/dist -v0 + pkg.$*/setup install --distdir pkg.$*/dist -v0 ===================================== testsuite/tests/plugins/T24486-plugin/Setup.hs ===================================== @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain ===================================== testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal ===================================== @@ -0,0 +1,9 @@ +Name: T24486-plugin +Version: 0.1 +Synopsis: For testing +Cabal-Version: >= 1.2 +Build-Type: Simple + +Library + Build-Depends: base, ghc + Exposed-Modules: T24486_Plugin ===================================== testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs ===================================== @@ -0,0 +1,6 @@ +module T24486_Plugin (plugin) where + +import GHC.Plugins + +plugin :: Plugin +plugin = defaultPlugin ===================================== testsuite/tests/plugins/T24486.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () ===================================== testsuite/tests/plugins/T24486_Helper.hs ===================================== @@ -0,0 +1,4 @@ +module T24486_Helper where + +helper :: Int +helper = 42 ===================================== testsuite/tests/plugins/all.T ===================================== @@ -395,3 +395,10 @@ test('T21730', pre_cmd('$MAKE -s --no-print-directory -C T21730-plugin package.T21730-plugin TOP={top}') ], makefile_test, []) + +test('T24486', + [extra_files(['T24486-plugin/', 'T24486_Helper.hs']), + when(opsys('mingw32'), skip), + pre_cmd('$MAKE -s --no-print-directory -C T24486-plugin package.T24486-plugin TOP={top}') + ], + makefile_test, []) ===================================== testsuite/tests/runghc/Makefile ===================================== @@ -23,6 +23,11 @@ T11247: -'$(RUNGHC)' foo. -'$(RUNGHC)' foo.bar +# runghc should honour -osuf for dependencies too (#16145). +T16145: + '$(RUNGHC)' -- -fobject-code -osuf=hs.o T16145 + printf '%s\n' *.hi *.o *.hs | LC_ALL=C sort + T17171a: '$(RUNGHC)' --ghc-arg=-Wall T17171a.hs T17171b: ===================================== testsuite/tests/runghc/T16145.hs ===================================== @@ -0,0 +1,5 @@ +module T16145 where + +import T16145_aux + +main = g ===================================== testsuite/tests/runghc/T16145.stdout ===================================== @@ -0,0 +1,6 @@ +T16145.hi +T16145.hs +T16145.hs.o +T16145_aux.hi +T16145_aux.hs +T16145_aux.hs.o ===================================== testsuite/tests/runghc/T16145_aux.hs ===================================== @@ -0,0 +1,4 @@ +module T16145_aux where + +g :: IO () +g = return () ===================================== testsuite/tests/runghc/all.T ===================================== @@ -4,6 +4,8 @@ test('T8601', req_interp, makefile_test, []) test('T11247', [req_interp, expect_broken(11247)], makefile_test, []) +test('T16145', req_interp, makefile_test, []) + test('T6132', [], compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5c7a63a086def4174deb6385f5594… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5c7a63a086def4174deb6385f5594… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/precise-fun-loc] compute a more accuate application chain head location
by Apoorv Ingle (＠ani) 03 Apr '26

03 Apr '26

Apoorv Ingle pushed to branch wip/ani/precise-fun-loc at Glasgow Haskell Compiler / GHC Commits: c9af140d by Apoorv Ingle at 2026-04-02T21:19:03-05:00 compute a more accuate application chain head location - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Head.hs - testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -243,7 +243,7 @@ tcApp accepts 4 arguments: 3. the argument list (types and terms) 4. The expected result type -PRECONDITION : the head (2.) and the list of arguments (3.) will +PRECONDITION : the head (2.) and the list of arguments (3.) are the de-constructred version of the expression (1.) POSTCONDITION: The return expression is the typechecked version of (1.) @@ -365,7 +365,7 @@ tcApp :: HsExpr GhcRn -- ^ The whole application (For error messages) -- See Note [tcApp: typechecking applications] -- See Note [splitHsApps] in GHC.Tc.Head tcApp rn_expr rn_fun rn_args exp_res_ty - = do { fun_lspan <- getFunSrcSpan rn_args + = do { fun_lspan <- getFunSrcSpan rn_fun rn_args ; traceTc "tcApp {" $ vcat [ text "rn_fun:" <+> ppr rn_fun , text "fun_lspan:" <+> ppr fun_lspan @@ -1958,14 +1958,14 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ -- generated by calls in arg do { traceTc "qla1" (ppr arg) - ; (rn_fun_arg, rn_args) <- splitHsApps arg + ; (rn_arg_head, rn_arg_args) <- splitHsApps arg ; traceTc "qla2" (ppr arg) - ; fun_lspan_arg <- getFunSrcSpan rn_args + ; fun_lspan_arg <- getFunSrcSpan rn_arg_head rn_arg_args -- Step 1: get the type of the head of the argument - ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_fun_arg + ; (fun_ue, mb_fun_ty) <- tcCollectingUsage $ tcInferAppHead_maybe rn_arg_head -- tcCollectingUsage: the use of an Id at the head generates usage-info -- See the call to `tcEmitBindingUsage` in `check_local_id`. So we must -- capture and save it in the `EValArgQL`. See (QLA6) in @@ -1974,8 +1974,8 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ ; traceTc "quickLookArg {" $ vcat [ text "arg:" <+> ppr arg , text "orig_arg_rho:" <+> ppr orig_arg_rho - , text "head:" <+> ppr rn_fun_arg <+> dcolon <+> ppr mb_fun_ty - , text "args:" <+> ppr rn_args ] + , text "head:" <+> ppr rn_arg_head <+> dcolon <+> ppr mb_fun_ty + , text "args:" <+> ppr rn_arg_args ] ; case mb_fun_ty of { Nothing -> skipQuickLook app_lspan larg sc_arg_ty ; -- fun is too complicated @@ -1983,11 +1983,11 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ -- step 2: use |-inst to instantiate the head applied to the arguments do { let arg_tc_head = (tc_fun_arg_head, fun_lspan_arg) - ; do_ql <- wantQuickLook rn_fun_arg + ; do_ql <- wantQuickLook rn_arg_head ; ((inst_args, app_res_rho), wanted) <- captureConstraints $ - tcInstFun do_ql True (rn_fun_arg, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_args + tcInstFun do_ql True (rn_arg_head, fun_lspan_arg) tc_fun_arg_head fun_sigma_arg_head rn_arg_args -- We must capture type-class and equality constraints here, but -- not usage information. See (QLA6) in Note [Quick Look at -- value arguments] @@ -2017,13 +2017,13 @@ quickLookArg1 pos app_lspan rn_head larg@(L _ arg) sc_arg_ty@(Scaled _ orig_arg_ ; when arg_influences_enclosing_call $ qlUnify app_res_rho orig_arg_rho - ; traceTc "quickLookArg done }" (ppr rn_fun_arg) + ; traceTc "quickLookArg done }" (ppr rn_arg_head) ; return (EValArgQL { eaql_loc_span = app_lspan , eaql_arg_ty = sc_arg_ty , eaql_larg = larg , eaql_tc_fun = arg_tc_head - , eaql_rn_fun = rn_fun_arg + , eaql_rn_fun = rn_arg_head , eaql_fun_ue = fun_ue , eaql_args = inst_args , eaql_wanted = wanted ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -223,14 +223,15 @@ addArgWrap wrap args -------------------- -getFunSrcSpan :: [HsExprArg 'TcpRn] -> TcM SrcSpan -getFunSrcSpan [] = getSrcSpanM -getFunSrcSpan (ETypeArg { ea_loc_span = l } : _) = return (locA l) -getFunSrcSpan (EValArg { ea_loc_span = l } : _) = return (locA l) -getFunSrcSpan (EPrag l _ : _) = return (locA l) -getFunSrcSpan (EWrap (EPar l) : _) = return (locA l) -getFunSrcSpan (EWrap (EExpand l _) : _) = return (locA l) -getFunSrcSpan (EWrap (EHsWrap {}) : args) = getFunSrcSpan args +getFunSrcSpan :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM SrcSpan +getFunSrcSpan (ExprWithTySig _ (L l _) _) _ = return (locA l) +getFunSrcSpan _ [] = getSrcSpanM +getFunSrcSpan _ (ETypeArg { ea_loc_span = l } : _) = return (locA l) +getFunSrcSpan _ (EValArg { ea_loc_span = l } : _) = return (locA l) +getFunSrcSpan _ (EPrag l _ : _) = return (locA l) +getFunSrcSpan _ (EWrap (EPar l) : _) = return (locA l) +getFunSrcSpan _ (EWrap (EExpand l _) : _) = return (locA l) +getFunSrcSpan f (EWrap (EHsWrap {}) : args) = getFunSrcSpan f args -------------------- isHsValArg :: HsExprArg id -> Bool @@ -294,10 +295,10 @@ instance Outputable EWrap where splitHsApps :: HsExpr GhcRn -> TcM (HsExpr GhcRn, [HsExprArg 'TcpRn]) splitHsApps e = go e [] where - go (HsPar _ (L l fun)) args = go fun (EWrap (EPar l) : args) - go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) - go (HsAppType _ (L l fun) ty) args = go fun (mkETypeArg l ty : args) - go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) + go (HsPar _ (L l fun)) args = go fun (EWrap (EPar l) : args) + go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) + go (HsAppType _ (L l fun) ty) args = go fun (mkETypeArg l ty : args) + go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) go fun args = do { mb_hse <- tcExpand fun ; case mb_hse of Just (HSE { hse_ctxt = orig, hse_exp = L l fun' }) ===================================== testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr ===================================== @@ -20,7 +20,8 @@ SplicesUsed.hs:8:26: warning: [GHC-88464] [-Wpartial-type-signatures (in -Wdefau • Found type wildcard ‘_’ standing for ‘Bool’ • In the first argument of ‘Maybe’, namely ‘_’ In an expression type signature: Maybe _ - In the expression: Just True :: Maybe _ + In the first argument of ‘id :: _a -> _a’, namely + ‘(Just True :: Maybe _)’ • Relevant bindings include maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9af140d496ca06466d1d14678fe909… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c9af140d496ca06466d1d14678fe909… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: driver: recognise .dyn_o as a valid object file to link if passed on the command line.
by Marge Bot (＠marge-bot) 03 Apr '26

03 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a116ca75 by Zubin Duggal at 2026-04-02T21:29:21-04:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 - - - - - 5ca0ec57 by Simon Jakobi at 2026-04-02T21:29:24-04:00 Add regression test for #16145 Closes #16145. - - - - - de30ea3b by Matthew Pickering at 2026-04-02T21:29:24-04:00 bytecode: Add magic header/version to bytecode files In order to avoid confusing errors when using stale interface files (ie from an older compiler version), we add a simple header/version check like the one for interface files. Fixes #27068 - - - - - f6cd6f2d by fendor at 2026-04-02T21:29:25-04:00 Add constants for bytecode in-memory buffer size Introduce a common constant for the default size of the .gbc and .bytecodelib binary buffer. The buffer is by default set to 1 MB. - - - - - 1a2b7f11 by Duncan Coutts at 2026-04-02T21:29:26-04:00 Add a rts posix FdWakup utility module This will be used to implement wakeupIOManager for in-RTS I/O managers. It provides a notification/wakeup mechanism using FDs, suitable for situations when a thread is blocked on a set of fds anyway. It uses the classic self-pipe trick, or equivalently eventfd on supported platforms. This will initially be used to implement prompt interrupt or shutdown of the posix ticker thread. - - - - - 66f81c55 by Duncan Coutts at 2026-04-02T21:29:26-04:00 Add prompt shutdown to the pthread ticker implementation. The Linux timerfd ticker monitors a pipe which is used by exitTicker to ensure a prompt wakeup and shutdown. The pthread ticker lacked this and so would only exit at the next ticker wakeup (10ms by default). This patch adds the same mechanism to the pthread ticker. This changes the pthread ticker from waiting by using nanosleep() to waiting using either ppoll() or select(), so that it can wait on both a time and a file descriptor. On Linux at least, a test program to compare the timing jitter of these APIs shows that using nanpsleep, ppoll or select makes no statistical difference to the maximum or average jitter. This is a step towards unifying the posix ticker implementations, so that we can have just one portable one (albeit with some limited cpp). It is also a step towards using the ticker as part of a more general implementation of wakeUpRts, since this will require a method to wake the rts from a signal handler context (ctl-c handler). - - - - - 13b86936 by Duncan Coutts at 2026-04-02T21:29:26-04:00 Update ticker header commentary It was antique and didn't apply even to the previous implementation, and certainly not to the updated one. - - - - - 1f0d1bad by Duncan Coutts at 2026-04-02T21:29:26-04:00 Remove the timerfd-based ticker implementation There does not appear to be any remaining advantage on Linux to using the timerfd ticker implementation over the portable one (using ppoll on Linux for precise timing). The eventfd implementation was originally added at a time when Linux was still using a signal based implementation. So it made sense at the time. See (closed) issue #10840. - - - - - 21e4fd73 by Duncan Coutts at 2026-04-02T21:29:26-04:00 Consolidate to a single posix ticker implementation Previously we had four implementations, two using signals and two using threads. Having just one should make behaviour more consistent between platforms, and should make maintenance easier. - - - - - 119c0dfc by mangoiv at 2026-04-02T21:29:27-04:00 testsuite: filter stderr for static001 on darwin This reactivates the test on x86_64 darwin as this should have been done long ago and ignores warnings emitted by ranlib on newer version of the darwin toolchain since they are benign. (no symbols for stub libraries) Fixes #27116 - - - - - 3d644081 by mangoiv at 2026-04-02T21:29:28-04:00 issue template: fix add bug label - - - - - b5c7a63a by Sylvain Henry at 2026-04-02T21:29:37-04:00 Add more canned GC functions for common register patterns (#27142) Based on analysis of heap-check sites across the GHC compiler and Cabal, the following patterns were not covered by existing canned GC functions but occurred frequently enough to warrant specialisation: stg_gc_ppppp -- 5 GC pointers stg_gc_ip -- unboxed word + GC pointer stg_gc_pi -- GC pointer + unboxed word stg_gc_ii -- two unboxed words stg_gc_bpp -- byte (I8) + two GC pointers Adding these reduces the fraction of heap-check sites falling back to the generic GC path from ~1.4% to ~0.4% when compiling GHC itself. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 30 changed files: - .gitlab/issue_templates/default.md - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/StgToCmm/Heap.hs - rts/HeapStackCheck.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - + rts/posix/FdWakeup.c - + rts/posix/FdWakeup.h - rts/posix/Ticker.c - − rts/posix/ticker/Pthread.c - − rts/posix/ticker/TimerFd.c - rts/rts.cabal - testsuite/driver/testlib.py - testsuite/tests/driver/all.T - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - testsuite/tests/runghc/Makefile - + testsuite/tests/runghc/T16145.hs - + testsuite/tests/runghc/T16145.stdout - + testsuite/tests/runghc/T16145_aux.hs - testsuite/tests/runghc/all.T Changes: ===================================== .gitlab/issue_templates/default.md ===================================== @@ -20,5 +20,5 @@ Optional: * System Architecture: -/label ~bug +/label ~"T::bug" /label ~"needs triage" ===================================== compiler/GHC/ByteCode/Serialize.hs ===================================== @@ -25,22 +25,26 @@ where import GHC.Prelude import GHC.ByteCode.Binary -import GHC.ByteCode.Types import GHC.ByteCode.Recomp.Binary (computeFingerprint) -import GHC.Driver.Env +import GHC.ByteCode.Types import GHC.Driver.DynFlags +import GHC.Driver.Env import GHC.Iface.Binary import GHC.Iface.Recomp.Binary (putNameLiterally) import GHC.Linker.Types +import GHC.Settings.Constants (hiVersion) import GHC.Unit.Types import GHC.Utils.Binary -import GHC.Utils.TmpFs -import GHC.Utils.Logger import GHC.Utils.Fingerprint (Fingerprint) +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.TmpFs import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS +import Data.Char (ord) import Data.Traversable +import Data.Word import System.Directory import System.FilePath @@ -79,21 +83,35 @@ The ticket where bytecode objects were dicussed is #26298 See Note [-fwrite-byte-code is not the default] See Note [Recompilation avoidance with bytecode objects] +See Note [Persistent bytecode file headers] +Note [Persistent bytecode file headers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Persistent bytecode files (`.gbc`) and bytecode libraries (`.bytecodelib`) +are version-specific binary formats. Without a small file-level header, stale +or corrupt files are only discovered once we start deserialising the payload, +which can lead to confusing failures. + +To make these failures explicit, we write a file-kind-specific magic word and +the current `hiVersion` ahead of the binary payload. Readers validate this +header before setting up the normal `Name`/`FastString` deserialisation +machinery. This follows the same approach as normal interface files. -} writeBytecodeLib :: BytecodeLib -> FilePath -> IO () writeBytecodeLib lib path = do odbco <- encodeBytecodeLib lib createDirectoryIfMissing True (takeDirectory path) - bh' <- openBinMem (1024 * 1024) + bh' <- openBinMem initBinMemSize bh <- addBinNameWriter bh' + writePersistentBytecodeHeader BytecodeLibraryFile bh putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh path readBytecodeLib :: HscEnv -> FilePath -> IO OnDiskBytecodeLib readBytecodeLib hsc_env path = do bh' <- readBinMem path + readPersistentBytecodeHeader BytecodeLibraryFile path bh' bh <- addBinNameReader (hsc_NC hsc_env) bh' res <- getWithUserData (hsc_NC hsc_env) bh pure res @@ -185,6 +203,7 @@ readBinByteCode hsc_env f = do readOnDiskModuleByteCode :: HscEnv -> FilePath -> IO OnDiskModuleByteCode readOnDiskModuleByteCode hsc_env f = do bh' <- readBinMem f + readPersistentBytecodeHeader ModuleByteCodeFile f bh' bh <- addBinNameReader (hsc_NC hsc_env) bh' getWithUserData (hsc_NC hsc_env) bh @@ -192,9 +211,10 @@ readOnDiskModuleByteCode hsc_env f = do writeBinByteCode :: FilePath -> ModuleByteCode -> IO () writeBinByteCode f cbc = do createDirectoryIfMissing True (takeDirectory f) - bh' <- openBinMem (1024 * 1024) + bh' <- openBinMem initBinMemSize bh <- addBinNameWriter bh' odbco <- encodeOnDiskModuleByteCode cbc + writePersistentBytecodeHeader ModuleByteCodeFile bh putWithUserData QuietBinIFace NormalCompression bh odbco writeBinMem bh f @@ -213,3 +233,64 @@ fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> fingerprintModuleByteCodeContents modl cbc foreign_files = do foreign_contents <- readObjectFiles foreign_files pure $ computeFingerprint putNameLiterally (modl, cbc, foreign_contents) + +-- ---------------------------------------------------------------------------- +-- ByteCode module and library magic header. +-- ---------------------------------------------------------------------------- + +data PersistentBytecodeFile + = ModuleByteCodeFile + | BytecodeLibraryFile + +-- See Note [Persistent bytecode file headers] +writePersistentBytecodeHeader :: PersistentBytecodeFile -> WriteBinHandle -> IO () +writePersistentBytecodeHeader file_kind bh = do + put_ bh (persistentBytecodeMagic file_kind) + put_ bh (show hiVersion) + +readPersistentBytecodeHeader :: PersistentBytecodeFile -> FilePath -> ReadBinHandle -> IO () +readPersistentBytecodeHeader file_kind path bh = do + let mismatch what expected actual = + throwGhcExceptionIO $ ProgramError $ + persistentBytecodeFileDescription file_kind ++ " header mismatch in " ++ path ++ + ": " ++ what ++ " (expected " ++ expected ++ ", got " ++ actual ++ ")" + + magic <- get bh + let expected_magic = persistentBytecodeMagic file_kind + if unFixedLength magic == unFixedLength expected_magic + then pure () + else mismatch "magic" (show $ unFixedLength expected_magic) (show $ unFixedLength magic) + + version <- get bh + let expected_version = show hiVersion + if version == expected_version + then pure () + else mismatch "version" expected_version version + +persistentBytecodeFileDescription :: PersistentBytecodeFile -> String +persistentBytecodeFileDescription ModuleByteCodeFile = "bytecode file" +persistentBytecodeFileDescription BytecodeLibraryFile = "bytecode library" + +persistentBytecodeMagic :: PersistentBytecodeFile -> FixedLengthEncoding Word32 +persistentBytecodeMagic file_kind = + case file_kind of + ModuleByteCodeFile -> asciiWord32 "gbc0" + BytecodeLibraryFile -> asciiWord32 "bcl0" + +-- | Encode a 4-letter word into a single Word32. +asciiWord32 :: String -> FixedLengthEncoding Word32 +asciiWord32 [a, b, c, d] = + FixedLengthEncoding $ + (fromIntegral (ord a) `shiftL` 24) .|. + (fromIntegral (ord b) `shiftL` 16) .|. + (fromIntegral (ord c) `shiftL` 8) .|. + fromIntegral (ord d) +asciiWord32 _ = error "asciiWord32: expected exactly four ASCII characters" + +-- ---------------------------------------------------------------------------- +-- Constants and utils +-- ---------------------------------------------------------------------------- + +-- | Initial ram buffer to allocate for writing .gbc and .bytecodelib files. +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 -- 1 MB ===================================== compiler/GHC/Driver/Phases.hs ===================================== @@ -262,7 +262,7 @@ objish_suffixes :: Platform -> [String] -- the GHC-compiled code will run objish_suffixes platform = case platformOS platform of OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] - _ -> [ "o" ] + _ -> [ "o", "dyn_o"] dynlib_suffixes :: Platform -> [String] dynlib_suffixes platform = case platformOS platform of ===================================== compiler/GHC/StgToCmm/Heap.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Stg to C--: heap management functions @@ -44,7 +45,7 @@ import GHC.Types.Id ( Id ) import GHC.Unit import GHC.Platform import GHC.Platform.Profile -import GHC.Data.FastString( mkFastString, fsLit ) +import GHC.Data.FastString( FastString ) import GHC.Utils.Panic( sorry ) import Control.Monad (when) @@ -125,7 +126,7 @@ allocHeapClosure rep info_ptr use_cc payload = do -- ie 1 *before* the info-ptr word of new object. base <- getHpRelOffset info_offset - emitComment $ mkFastString "allocHeapClosure" + emitComment "allocHeapClosure" emitSetDynHdr base info_ptr use_cc -- Fill in the fields @@ -460,35 +461,41 @@ genericGC checkYield code call <- mkCall generic_gc (GC, GC) [] [] updfr_sz [] heapCheck False checkYield (call <*> mkBranch lretry) code +-- | Predefined ("canned") GC functions +-- +-- Functions have been added to cover 99% of the GC calls made in GHC and Cabal. +-- See #27142. cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint platform regs - = case map localRegType regs of - [] -> Just (mkGcLabel "stg_gc_noregs") - [ty] - | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1") - | isFloatType ty -> case width of - W32 -> Just (mkGcLabel "stg_gc_f1") - W64 -> Just (mkGcLabel "stg_gc_d1") - _ -> Nothing - - | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing - where - width = typeWidth ty - [ty1,ty2] - | isGcPtrType ty1 - && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp") - [ty1,ty2,ty3] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp") - [ty1,ty2,ty3,ty4] - | isGcPtrType ty1 - && isGcPtrType ty2 - && isGcPtrType ty3 - && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp") - _otherwise -> Nothing +cannedGCEntryPoint platform regs = + case map localRegType regs of + [] -> ret "stg_gc_noregs" + [ty] + | is_gc ty -> ret "stg_gc_unpt_r1" + | is_f32 ty -> ret "stg_gc_f1" + | is_f64 ty -> ret "stg_gc_d1" + | is_wn ty -> ret "stg_gc_unbx_r1" + | is_w64 ty -> ret "stg_gc_l1" + [ty1,ty2] + | is_gc ty1 && is_gc ty2 -> ret "stg_gc_pp" + | is_gc ty1 && is_wn ty2 -> ret "stg_gc_pi" + | is_wn ty1 && is_gc ty2 -> ret "stg_gc_ip" + | is_wn ty1 && is_wn ty2 -> ret "stg_gc_ii" + [ty1,ty2,ty3] + | is_gc ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_ppp" + | is_w8 ty1 && is_gc ty2 && is_gc ty3 -> ret "stg_gc_bpp" + [ty1,ty2,ty3,ty4] + | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 -> ret "stg_gc_pppp" + [ty1,ty2,ty3,ty4,ty5] + | is_gc ty1 && is_gc ty2 && is_gc ty3 && is_gc ty4 && is_gc ty5 -> ret "stg_gc_ppppp" + _ -> Nothing + where + ret fs = Just (mkGcLabel fs) + is_gc ty = isGcPtrType ty + is_wn ty = isBitsType ty && typeWidth ty == wordWidth platform + is_w8 ty = isBitsType ty && typeWidth ty == W8 + is_w64 ty = isBitsType ty && typeWidth ty == W64 + is_f32 ty = isFloatType ty && typeWidth ty == W32 + is_f64 ty = isFloatType ty && typeWidth ty == W64 -- Note [stg_gc arguments] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -514,8 +521,8 @@ generic_gc :: CmmExpr generic_gc = mkGcLabel "stg_gc_noregs" -- | Create a CLabel for calling a garbage collector entry point -mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s))) +mkGcLabel :: FastString -> CmmExpr +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId s)) ------------------------------- heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a ===================================== rts/HeapStackCheck.cmm ===================================== @@ -373,8 +373,6 @@ stg_gc_l1 return (L_ l) jump stg_gc_noregs (stg_ret_l_info, l) (); } -/*-- Unboxed tuples with multiple pointers -------------------------------- */ - stg_gc_pp return (P_ arg1, P_ arg2) { call stg_gc_noregs(); @@ -393,6 +391,36 @@ stg_gc_pppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4) return (arg1,arg2,arg3,arg4); } +stg_gc_ppppp return (P_ arg1, P_ arg2, P_ arg3, P_ arg4, P_ arg5) +{ + call stg_gc_noregs(); + return (arg1,arg2,arg3,arg4,arg5); +} + +stg_gc_ip return (W_ arg1, P_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_pi return (P_ arg1, W_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_ii return (W_ arg1, W_ arg2) +{ + call stg_gc_noregs(); + return (arg1,arg2); +} + +stg_gc_bpp return (I8 arg1, P_ arg2, P_ arg3) +{ + call stg_gc_noregs(); + return (arg1,arg2,arg3); +} + /* ----------------------------------------------------------------------------- Generic function entry heap check code. ===================================== rts/RtsSymbols.c ===================================== @@ -499,6 +499,11 @@ extern char **environ; SymI_HasDataProto(stg_gc_pp) \ SymI_HasDataProto(stg_gc_ppp) \ SymI_HasDataProto(stg_gc_pppp) \ + SymI_HasDataProto(stg_gc_ppppp) \ + SymI_HasDataProto(stg_gc_ip) \ + SymI_HasDataProto(stg_gc_pi) \ + SymI_HasDataProto(stg_gc_ii) \ + SymI_HasDataProto(stg_gc_bpp) \ SymI_HasDataProto(__stg_gc_fun) \ SymI_HasDataProto(stg_gc_fun_info) \ SymI_HasDataProto(stg_yield_noregs) \ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -361,6 +361,11 @@ RTS_FUN_DECL(stg_gc_l1); RTS_FUN_DECL(stg_gc_pp); RTS_FUN_DECL(stg_gc_ppp); RTS_FUN_DECL(stg_gc_pppp); +RTS_FUN_DECL(stg_gc_ppppp); +RTS_FUN_DECL(stg_gc_ip); +RTS_FUN_DECL(stg_gc_pi); +RTS_FUN_DECL(stg_gc_ii); +RTS_FUN_DECL(stg_gc_bpp); RTS_RET(stg_gc_fun); RTS_FUN_DECL(__stg_gc_fun); ===================================== rts/posix/FdWakeup.c ===================================== @@ -0,0 +1,141 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * This is used to provide a mechanism to wake a thread when it is blocked + * waiting on fds and timeouts. The mechanism works by including the read end + * fd into the set of fds the thread waits on, and when a wake up is needed, + * the write end fd is used. + * + * This is implemented using either eventfd() or pipe(). + * + * Linux 2.6.22+ and FreeBSD 13+ support eventfd. It is a single fd with a + * 64bit counter. It uses fewer resources than a pipe (less memory and one + * rather than two fds), and is a tad faster (on the order of 5-10%). Using + * write() adds to the counter, while read() reads and resets it. Thus + * multiple writes are combined automatically into a single corresponding + * read. + * + * Otherwise we use a classic unix pipe. + * + * In both implementations, multiple sendFdWakeup notifcations (without + * interleaved collectFdWakeup) are combined to a single notification. This + * is automatic given the semantics of eventfd, while for pipe we implement + * it explicitly by draining the pipe in collectFdWakeup. + * + * -------------------------------------------------------------------------*/ + +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "FdWakeup.h" + +#include <fcntl.h> +#include <unistd.h> + +#ifdef HAVE_SYS_EVENTFD_H +#include <sys/eventfd.h> +#endif + +#if !defined(HAVE_EVENTFD) \ + || (defined(HAVE_EVENTFD) && !(defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK))) +static void fcntl_CLOEXEC_NONBLOCK(int fd) +{ + int res1 = fcntl(fd, F_SETFD, FD_CLOEXEC); + int res2 = fcntl(fd, F_SETFL, O_NONBLOCK); + if (RTS_UNLIKELY(res1 < 0 || res2 < 0)) { + sysErrorBelch("newFdWakeup fcntl()"); + stg_exit(EXIT_FAILURE); + } +} +#endif + +void newFdWakeup(int *wakeup_fd_r, int *wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + int wakeup_fd; +#if defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK) + wakeup_fd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK); +#else + wakeup_fd = eventfd(0, 0); + if (wakeup_fd >= 0) fcntl_CLOEXEC_NONBLOCK(wakeup_fd); +#endif + if (RTS_UNLIKELY(wakeup_fd < 0)) { + sysErrorBelch("newFdWakeup eventfd()"); + stg_exit(EXIT_FAILURE); + } + /* eventfd uses the same fd for each end */ + *wakeup_fd_r = wakeup_fd; + *wakeup_fd_w = wakeup_fd; +#else + int pipefd[2]; + int res; + res = pipe(pipefd); + if (RTS_UNLIKELY(res < 0)) { + sysErrorBelch("newFdWakeup pipe"); + stg_exit(EXIT_FAILURE); + } + fcntl_CLOEXEC_NONBLOCK(pipefd[0]); + fcntl_CLOEXEC_NONBLOCK(pipefd[1]); + *wakeup_fd_r = pipefd[0]; /* read end */ + *wakeup_fd_w = pipefd[1]; /* write end */ +#endif +} + +void closeFdWakeup(int wakeup_fd_r, int wakeup_fd_w) +{ +#if defined(HAVE_EVENTFD) + ASSERT(wakeup_fd_r == wakeup_fd_w); + close(wakeup_fd_r); +#else + ASSERT(wakeup_fd_r != wakeup_fd_w); + close(wakeup_fd_r); + close(wakeup_fd_w); +#endif +} + +/* This is safe to use from a signal handler. Using write() to a pipe + * or eventfd is fine. */ +void sendFdWakeup(int wakeup_fd_w) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t val = 1; + res = write(wakeup_fd_w, &val, 8); +#else + unsigned char buf = 1; + res = write(wakeup_fd_w, &buf, 1); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* Unlikely the pipe buffer will fill, but it would not be an error. */ + if (errno == EAGAIN) return; + sysErrorBelch("sendFdWakeup write"); + stg_exit(EXIT_FAILURE); + } +} + +void collectFdWakeup(int wakeup_fd_r) +{ + int res; +#if defined(HAVE_EVENTFD) + uint64_t buf; + /* eventfd combines events into one counter, so a single read is enough */ + res = read(wakeup_fd_r, &buf, 8); +#else + /* Drain the pipe buffer. Multiple wakeup notifications could + * have been sent before we have a chance to collect them. + */ + uint64_t buf; + do { + res = read(wakeup_fd_r, &buf, 8); + } while (res == 8); +#endif + if (RTS_UNLIKELY(res < 0)) { + /* After the first pipe read, it could block */ + if (errno == EAGAIN) return; + sysErrorBelch("collectFdWakeup read"); + stg_exit(EXIT_FAILURE); + } +} ===================================== rts/posix/FdWakeup.h ===================================== @@ -0,0 +1,40 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2025 + * + * Utilities for a simple fd-based cross-thread wakeup mechanism. + * + * It provides a mechanism for a thread that block on fds to add a simple + * wakeup/notification feature. + * + * Start with newFdWakeup, and pass the fd_r to the thread that needs the + * wakeup feature. The thread that needs to be woken should include the fd_r + * into the set of fds that the thread waits on (e.g. using poll or similar). + * If this fd becomes ready for read, the thread must call collectFdWakeup, + * and when a wake up is needed, the write end fd is used. In any other thread + * (or in a signal handler), call sendFdWakeup(fd_w) to (asynchronously) cause + * the wakeup. + * + * There is no message payload. Multiple wakeups may be combined (if they're + * sent multiple times before the notified thread can wake and call + * collectFdWakeup). + * + * The implementation uses pipe() or eventfd() on supported OSs. + * + * Prototypes for functions in FdWakeup.c + * + * -------------------------------------------------------------------------*/ + +#pragma once + +#include "BeginPrivate.h" + +void newFdWakeup(int *fd_r, int *fd_w); +void closeFdWakeup(int fd_r, int fd_w); + +/* This is safe to use from a signal handler */ +void sendFdWakeup(int fd_w); +void collectFdWakeup(int fd_r); + +#include "EndPrivate.h" + ===================================== rts/posix/Ticker.c ===================================== @@ -1,19 +1,53 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team, 1995-2007 + * (c) The GHC Team, 1995-2026 * - * Posix implementation(s) of the interval timer for profiling and pre-emptive - * scheduling. + * The posix implementation of the interval timer, used for pre-emptive + * scheduling of Haskell threads, and for sample based profiling. + * + * This file defines the "ticker": the platform-specific service to install and + * run the timer. See rts/Timer.c for the platform-dependent view of interval + * timing. * * ---------------------------------------------------------------------------*/ -/* The interval timer is used for profiling and for context switching. - * This file defines the platform-specific services to install and run the - * timers, and we call this the ticker. See rts/Timer.c for the - * platform-dependent view of interval timing. +/* This implementation uses a posix thread which repeatedly blocks on a timeout + * using either the ppoll() or select() API. This lets it also block on a file + * descriptor for early wakeup. + * + * The design uses a simple relative time delay with no catchup. That is, time + * spent by the ticker thread itself (e.g. flushing eventlog buffers) is not + * accounted for, and the next tick is delayed by that much (modulo wakeup + * jitter). This is probably the right thing to do: generally in realtime + * systems one does not want to try to catch up when behind, since that tends + * towards oversubscribing resources. Graceful degredation is usually + * preferable. + * + * Experimental results (on Linux 6.18 on x86-64) to measure the typical + * difference between the requested wakeup time and actual wakeup time for + * different delay intervals: + * + * interval typical actual wakeup time after due time + * 10000us 340 -- 400us (this is the default interval) + * 1000us 55 -- 100us + * 100us 55us + * 10us 55us + * + * While there's quite a bit of variance to these numbers, the results do not + * vary significantly between using select, ppoll or nanosleep. + * + * On Linux at least, for longer delays the kernel allows itself lower wakeup + * accuracy (which allows it to save power by coalescing multiple wakeups). + * Similarly, the reason for 55us on the low end is that the default thread + * timer slack on Linux is 50us, and context switch time accounts for the + * remainder. + * + * In conclusion, on Linux at least, the accuracy is fine, both for the + * default interval (10ms, 10000us) and for shorter intervals used during + * profiling. * * Historically we had ticker implementations using signals. This was always a - * rather shakey thing to do but we had few alternatives. + * rather shakey thing to do but we originally had few alternatives. * - One problem with using signals is that there are severe limits on what * code can be called from signal handlers. In particular it's not possible * to take locks in a signal handler contex. This was enough for contex @@ -23,17 +57,245 @@ * calls (#10840) or can be overwritten by user code. */ -/* Select a ticker implementation to use: - * - * On modern Linux, FreeBSD and NetBSD we can use timerfd_create and a thread - * that waits on it using poll. Linux has had timerfd since version 2.6.25. - * NetBSD has had timerfd since version 10, and FreeBSD since version 15. - * - * For older version of linux/bsd without timerfd, and for all other posix - * platforms, we use the implementation using posix pthreads and nanosleep(). +#include "rts/PosixSource.h" +#include "Rts.h" + +#include "Ticker.h" +#include "RtsUtils.h" +#include "Proftimer.h" +#include "Schedule.h" +#include "posix/Clock.h" +#include "posix/FdWakeup.h" + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 +/* We prefer the ppoll() function if available since it allows sanely waiting + * on a single fd with precise timeouts (nanosecond precision). It is not in + * the posix standard however and some platforms (notably glibc and freebsd) + * need special CPP defines to make it available: + */ +#define _GNU_SOURCE 1 +#define __BSD_VISIBLE 1 +#include <signal.h> +#include <poll.h> +#else +/* Otherwise we use the classic select(), which does have microsecond + * precision, but requires we build three whole 1024 bit (128 byte) fd sets + * just to wait on one fd. */ -#if defined(HAVE_SYS_TIMERFD_H) -#include "ticker/TimerFd.c" +#include <sys/select.h> +#endif + +#include <time.h> +#if HAVE_SYS_TIME_H +# include <sys/time.h> +#endif + +#if defined(HAVE_SIGNAL_H) +# include <signal.h> +#endif + +#include <string.h> + +#include <pthread.h> +#if defined(HAVE_PTHREAD_NP_H) +#include <pthread_np.h> +#endif +#include <unistd.h> +#include <fcntl.h> + +static Time itimer_interval = DEFAULT_TICK_INTERVAL; + +// Should we be firing ticks? +// Writers to this must hold the mutex below. +static bool stopped = false; + +// should the ticker thread exit? +// This can be set without holding the mutex. +static bool exited = true; + +// Signaled when we want to (re)start the timer +static Condition start_cond; +static Mutex mutex; +static OSThreadId thread; + +// fds for interrupting the ticker +static int interruptfd_r = -1, interruptfd_w = -1; + +static void *itimer_thread_func(void *_handle_tick) +{ + TickProc handle_tick = _handle_tick; + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + struct pollfd pollfds[1]; + + pollfds[0].fd = interruptfd_r; + pollfds[0].events = POLLIN; + + struct timespec ts = { .tv_sec = TimeToSeconds(itimer_interval) + , .tv_nsec = TimeToNS(itimer_interval) % 1000000000 + }; #else -#include "ticker/Pthread.c" + fd_set selectfds; + FD_ZERO(&selectfds); + FD_SET(interruptfd_r, &selectfds); + + struct timeval tv = { .tv_sec = TimeToSeconds(itimer_interval) + /* convert remainder time in nanoseconds + to microseconds, rounding up: */ + , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000) + + 999) / 1000 + }; +#endif + + // Relaxed is sufficient: If we don't see that exited was set in one iteration we will + // see it next time. + while (!RELAXED_LOAD_ALWAYS(&exited)) { + +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1 + int nfds = 1; + int nready = ppoll(pollfds, nfds, &ts, NULL); +#else + struct timeval tv_tmp = tv; // copy since select may change this value. + int nfds = interruptfd_r+1; + int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp); +#endif + // In either case (ppoll or select), the result nready is the number + // of fds that are ready. + if (RTS_LIKELY(nready == 0)) { + // Timer expired, not interrupted, continue. + } else if (nready > 0) { + // We only monitor one fd (the interruptfd_r), so we know + // it is that fd that is ready without any further checks. + collectFdWakeup(interruptfd_r); + // No further action needed, continue on to handling the final tick + // and then stop. + + // Note that we rely on sendFdWakeup and select/poll to provide the + // happens-before relation. So if 'exited' was set before calling + // sendFdWakeup, then we should be able to reliably read it after. + // And thus reading 'exited' in the while loop guard is ok. + } else { + // While the RTS attempts to mask signals, some foreign libraries + // that rely on signal delivery may unmask them. Consequently we + // may see EINTR. See #24610. + if (errno != EINTR) { + sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); + } + } + + // first try a cheap test + if (RELAXED_LOAD_ALWAYS(&stopped)) { + OS_ACQUIRE_LOCK(&mutex); + // should we really stop? + if (stopped) { + waitCondition(&start_cond, &mutex); + } + OS_RELEASE_LOCK(&mutex); + } else { + handle_tick(0); + } + } + + return NULL; +} + +void +initTicker (Time interval, TickProc handle_tick) +{ + itimer_interval = interval; + stopped = true; + exited = false; +#if defined(HAVE_SIGNAL_H) + sigset_t mask, omask; + int sigret; +#endif + int ret; + + initCondition(&start_cond); + initMutex(&mutex); + + /* Open the interrupt fd synchronously. + * + * We used to do it in itimer_thread_func (i.e. in the timer thread) but it + * meant that some user code could run before it and get confused by the + * allocation of the timerfd. + * + * See hClose002 which unsafely closes a file descriptor twice expecting an + * exception the second time: it sometimes failed when the second call to + * "close" closed our own timerfd which inadvertently reused the same file + * descriptor closed by the first call! (see #20618) + */ + + if (interruptfd_r != -1) { + // don't leak the old file descriptors after a fork (#25280) + closeFdWakeup(interruptfd_r, interruptfd_w); + } + newFdWakeup(&interruptfd_r, &interruptfd_w); + + /* + * Create the thread with all blockable signals blocked, leaving signal + * handling to the main and/or other threads. This is especially useful in + * the non-threaded runtime, where applications might expect sigprocmask(2) + * to effectively block signals. + */ +#if defined(HAVE_SIGNAL_H) + sigfillset(&mask); + sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); +#endif + ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); +#if defined(HAVE_SIGNAL_H) + if (sigret == 0) + pthread_sigmask(SIG_SETMASK, &omask, NULL); #endif + + if (ret != 0) { + barf("Ticker: Failed to spawn thread: %s", strerror(errno)); + } +} + +void +startTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, false); + signalCondition(&start_cond); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +stopTicker(void) +{ + OS_ACQUIRE_LOCK(&mutex); + RELAXED_STORE(&stopped, true); + OS_RELEASE_LOCK(&mutex); +} + +/* There may be at most one additional tick fired after a call to this */ +void +exitTicker (bool wait) +{ + ASSERT(!SEQ_CST_LOAD(&exited)); + SEQ_CST_STORE(&exited, true); + // ensure that ticker wakes up if stopped + startTicker(); + sendFdWakeup(interruptfd_w); + + // wait for ticker to terminate if necessary + if (wait) { + if (pthread_join(thread, NULL)) { + sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); + } + closeFdWakeup(interruptfd_r, interruptfd_w); + closeMutex(&mutex); + closeCondition(&start_cond); + } else { + pthread_detach(thread); + } +} + +int +rtsTimerSignal(void) +{ + return SIGALRM; +} ===================================== rts/posix/ticker/Pthread.c deleted ===================================== @@ -1,195 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2007 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (rtsSleep(itimer_interval) != 0) { - sysErrorBelch("Ticker: sleep failed: %s", strerror(errno)); - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/posix/ticker/TimerFd.c deleted ===================================== @@ -1,291 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1995-2023 - * - * Interval timer for profiling and pre-emptive scheduling. - * - * ---------------------------------------------------------------------------*/ - -/* - * We use a realtime timer by default. I found this much more - * reliable than a CPU timer: - * - * Experiments with different frequencies: using - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, - * 1000us has <1% impact on runtime - * 100us has ~2% impact on runtime - * 10us has ~40% impact on runtime - * - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, - * I cannot get it to tick faster than 10ms (10000us) - * which isn't great for profiling. - * - * In the threaded RTS, we can't tick in CPU time because the thread - * which has the virtual timer might be idle, so the tick would never - * fire. Therefore we used to tick in realtime in the threaded RTS and - * in CPU time otherwise, but now we always tick in realtime, for - * several reasons: - * - * - resolution (see above) - * - consistency (-threaded is the same as normal) - * - more consistency: Windows only has a realtime timer - * - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, - * because the latter may jump around (NTP adjustments, leap seconds - * etc.). - */ - -#include "rts/PosixSource.h" -#include "Rts.h" - -#include "Ticker.h" -#include "RtsUtils.h" -#include "Proftimer.h" -#include "Schedule.h" -#include "posix/Clock.h" -#include <poll.h> - -#include <time.h> -#if HAVE_SYS_TIME_H -# include <sys/time.h> -#endif - -#if defined(HAVE_SIGNAL_H) -# include <signal.h> -#endif - -#include <string.h> - -#include <pthread.h> -#if defined(HAVE_PTHREAD_NP_H) -#include <pthread_np.h> -#endif -#include <unistd.h> -#include <fcntl.h> - -#include <sys/timerfd.h> - - -/* - * TFD_CLOEXEC has been added in Linux 2.6.26. - * If it is not available, we use fcntl(F_SETFD). - */ -#if !defined(TFD_CLOEXEC) -#define TFD_CLOEXEC 0 -#endif - -static Time itimer_interval = DEFAULT_TICK_INTERVAL; - -// Should we be firing ticks? -// Writers to this must hold the mutex below. -static bool stopped = false; - -// should the ticker thread exit? -// This can be set without holding the mutex. -static bool exited = true; - -// Signaled when we want to (re)start the timer -static Condition start_cond; -static Mutex mutex; -static OSThreadId thread; - -// file descriptor for the timer (Linux only) -static int timerfd = -1; - -// pipe for signaling exit -static int pipefds[2]; - -static void *itimer_thread_func(void *_handle_tick) -{ - TickProc handle_tick = _handle_tick; - uint64_t nticks; - ssize_t r = 0; - struct pollfd pollfds[2]; - - pollfds[0].fd = pipefds[0]; - pollfds[0].events = POLLIN; - pollfds[1].fd = timerfd; - pollfds[1].events = POLLIN; - - // Relaxed is sufficient: If we don't see that exited was set in one iteration we will - // see it next time. - while (!RELAXED_LOAD_ALWAYS(&exited)) { - if (poll(pollfds, 2, -1) == -1) { - // While the RTS attempts to mask signals, some foreign libraries - // may rely on signal delivery may unmask them. Consequently we may - // see EINTR. See #24610. - if (errno != EINTR) { - sysErrorBelch("Ticker: poll failed: %s", strerror(errno)); - } - } - - // We check the pipe first, even though the timerfd may also have triggered. - if (pollfds[0].revents & POLLIN) { - // the pipe is ready for reading, the only possible reason is that we're exiting - exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value - // no further action needed, skip ahead to handling the final tick and then stopping - } - else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading - r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now - - if ((r == 0) && (errno == 0)) { - /* r == 0 is expected only for non-blocking fd (in which case - * errno should be EAGAIN) but we use a blocking fd. - * - * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335) - * on some platforms we could see r == 0 and errno == 0. - */ - IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it.")); - } - else if (r != sizeof(nticks) && errno != EINTR) { - barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r); - } - } - - // first try a cheap test - if (RELAXED_LOAD_ALWAYS(&stopped)) { - OS_ACQUIRE_LOCK(&mutex); - // should we really stop? - if (stopped) { - waitCondition(&start_cond, &mutex); - } - OS_RELEASE_LOCK(&mutex); - } else { - handle_tick(0); - } - } - - close(timerfd); - return NULL; -} - -void -initTicker (Time interval, TickProc handle_tick) -{ - itimer_interval = interval; - stopped = true; - exited = false; -#if defined(HAVE_SIGNAL_H) - sigset_t mask, omask; - int sigret; -#endif - int ret; - - initCondition(&start_cond); - initMutex(&mutex); - - /* Open the file descriptor for the timer synchronously. - * - * We used to do it in itimer_thread_func (i.e. in the timer thread) but it - * meant that some user code could run before it and get confused by the - * allocation of the timerfd. - * - * See hClose002 which unsafely closes a file descriptor twice expecting an - * exception the second time: it sometimes failed when the second call to - * "close" closed our own timerfd which inadvertently reused the same file - * descriptor closed by the first call! (see #20618) - */ - struct itimerspec it; - it.it_value.tv_sec = TimeToSeconds(itimer_interval); - it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000; - it.it_interval = it.it_value; - - if (timerfd != -1) { - // don't leak the old file descriptors after a fork (#25280) - close(timerfd); - close(pipefds[0]); - close(pipefds[1]); - timerfd = -1; - } - - timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC); - if (timerfd == -1) { - barf("timerfd_create: %s", strerror(errno)); - } - if (!TFD_CLOEXEC) { - fcntl(timerfd, F_SETFD, FD_CLOEXEC); - } - if (timerfd_settime(timerfd, 0, &it, NULL)) { - barf("timerfd_settime: %s", strerror(errno)); - } - - if (pipe(pipefds) < 0) { - barf("pipe: %s", strerror(errno)); - } - - /* - * Create the thread with all blockable signals blocked, leaving signal - * handling to the main and/or other threads. This is especially useful in - * the non-threaded runtime, where applications might expect sigprocmask(2) - * to effectively block signals. - */ -#if defined(HAVE_SIGNAL_H) - sigfillset(&mask); - sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); -#endif - ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick); -#if defined(HAVE_SIGNAL_H) - if (sigret == 0) - pthread_sigmask(SIG_SETMASK, &omask, NULL); -#endif - - if (ret != 0) { - barf("Ticker: Failed to spawn thread: %s", strerror(errno)); - } -} - -void -startTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, false); - signalCondition(&start_cond); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -stopTicker(void) -{ - OS_ACQUIRE_LOCK(&mutex); - RELAXED_STORE(&stopped, true); - OS_RELEASE_LOCK(&mutex); -} - -/* There may be at most one additional tick fired after a call to this */ -void -exitTicker (bool wait) -{ - ASSERT(!SEQ_CST_LOAD(&exited)); - SEQ_CST_STORE(&exited, true); - // ensure that ticker wakes up if stopped - startTicker(); - - // wait for ticker to terminate if necessary - if (wait) { - // write anything to the pipe to trigger poll() in the ticker thread - if (write(pipefds[1], "stop", 5) < 0) { - sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno)); - } - - if (pthread_join(thread, NULL)) { - sysErrorBelch("Ticker: Failed to join: %s", strerror(errno)); - } - - // These need to happen AFTER the ticker thread has finished to prevent a race condition - // where the ticker thread closes the read end of the pipe before we're done writing to it. - close(pipefds[0]); - close(pipefds[1]); - - closeMutex(&mutex); - closeCondition(&start_cond); - } else { - pthread_detach(thread); - } -} - -int -rtsTimerSignal(void) -{ - return SIGALRM; -} ===================================== rts/rts.cabal ===================================== @@ -582,11 +582,9 @@ library posix/Ticker.c posix/OSMem.c posix/OSThreads.c + posix/FdWakeup.c posix/Poll.c posix/Select.c posix/Signals.c posix/Timeout.c posix/TTY.c - -- ticker/*.c - -- We don't want to compile posix/ticker/*.c, these will be #included - -- from Ticker.c ===================================== testsuite/driver/testlib.py ===================================== @@ -3043,6 +3043,12 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 + if opsys('darwin'): + s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + return s # normalise a .prof file, so that we can reasonably compare it against ===================================== testsuite/tests/driver/all.T ===================================== @@ -120,9 +120,7 @@ if config.os == 'darwin': else: only_darwin = skip -test('static001', [extra_files(['Static001.hs']), - only_darwin, - when(arch('x86_64'), expect_broken(8127))], +test('static001', [extra_files(['Static001.hs']), only_darwin], makefile_test, ['static001']) test('dynHelloWorld', ===================================== testsuite/tests/driver/bytecode-object/Makefile ===================================== @@ -159,3 +159,9 @@ bytecode_object25: "$(TEST_HC)" $(TEST_HC_OPTS) -c BytecodeForeign.hs -fbyte-code -fwrite-byte-code -fwrite-interface $(ghciWayFlags) "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -v1 -fno-hide-source-paths -fbyte-code -fwrite-byte-code -fwrite-interface BytecodeForeign.hs -e "testForeign" +# Test that corrupt bytecode file headers are rejected clearly. +bytecode_object26: + "$(TEST_HC)" $(TEST_HC_OPTS) -c BytecodeTest.hs -fbyte-code -fwrite-byte-code + @printf 'bad!' | dd of=BytecodeTest.gbc bs=1 count=4 conv=notrunc 2>/dev/null + ! "$(TEST_HC)" $(TEST_HC_OPTS) -c -bytecodelib -o linked.bytecode BytecodeTest.gbc 2> bytecode_object26.stderr + @grep -F "bytecode file header mismatch" bytecode_object26.stderr >/dev/null ===================================== testsuite/tests/driver/bytecode-object/all.T ===================================== @@ -26,3 +26,4 @@ test('bytecode_object22', bytecode_opts, makefile_test, ['bytecode_object22']) test('bytecode_object23', bytecode_opts, makefile_test, ['bytecode_object23']) test('bytecode_object24', bytecode_opts + [copy_files], makefile_test, ['bytecode_object24']) test('bytecode_object25', [bytecode_opts, req_interp, extra_files(['BytecodeForeign.hs', 'BytecodeForeign.c'])], makefile_test, ['bytecode_object25']) +test('bytecode_object26', [bytecode_opts], makefile_test, ['bytecode_object26']) ===================================== testsuite/tests/plugins/Makefile ===================================== @@ -238,3 +238,10 @@ test-late-plugin: .PHONY: T21730 T21730: "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T21730.hs -package-db T21730-plugin/pkg.T21730-plugin/local.package.conf + +# Test that .dyn_o files are accepted as valid object files on the command line +# without producing "ignoring unrecognised input" warnings (#24486) +.PHONY: T24486 +T24486: + "$(TEST_HC)" $(TEST_HC_OPTS) -v0 -c T24486_Helper.hs -osuf dyn_o + "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T24486.hs T24486_Helper.dyn_o -package-db T24486-plugin/pkg.T24486-plugin/local.package.conf -fplugin T24486_Plugin -plugin-package T24486-plugin ===================================== testsuite/tests/plugins/T24486-plugin/Makefile ===================================== @@ -0,0 +1,18 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean.%: + rm -rf pkg.$* + +HERE := $(abspath .) +$(eval $(call canonicalise,HERE)) + +package.%: + $(MAKE) -s --no-print-directory clean.$* + mkdir pkg.$* + "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs + "$(GHC_PKG)" init pkg.$*/local.package.conf + pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) + pkg.$*/setup build --distdir pkg.$*/dist -v0 + pkg.$*/setup install --distdir pkg.$*/dist -v0 ===================================== testsuite/tests/plugins/T24486-plugin/Setup.hs ===================================== @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain ===================================== testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal ===================================== @@ -0,0 +1,9 @@ +Name: T24486-plugin +Version: 0.1 +Synopsis: For testing +Cabal-Version: >= 1.2 +Build-Type: Simple + +Library + Build-Depends: base, ghc + Exposed-Modules: T24486_Plugin ===================================== testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs ===================================== @@ -0,0 +1,6 @@ +module T24486_Plugin (plugin) where + +import GHC.Plugins + +plugin :: Plugin +plugin = defaultPlugin ===================================== testsuite/tests/plugins/T24486.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = return () ===================================== testsuite/tests/plugins/T24486_Helper.hs ===================================== @@ -0,0 +1,4 @@ +module T24486_Helper where + +helper :: Int +helper = 42 ===================================== testsuite/tests/plugins/all.T ===================================== @@ -395,3 +395,10 @@ test('T21730', pre_cmd('$MAKE -s --no-print-directory -C T21730-plugin package.T21730-plugin TOP={top}') ], makefile_test, []) + +test('T24486', + [extra_files(['T24486-plugin/', 'T24486_Helper.hs']), + when(opsys('mingw32'), skip), + pre_cmd('$MAKE -s --no-print-directory -C T24486-plugin package.T24486-plugin TOP={top}') + ], + makefile_test, []) ===================================== testsuite/tests/runghc/Makefile ===================================== @@ -23,6 +23,11 @@ T11247: -'$(RUNGHC)' foo. -'$(RUNGHC)' foo.bar +# runghc should honour -osuf for dependencies too (#16145). +T16145: + '$(RUNGHC)' -- -fobject-code -osuf=hs.o T16145 + printf '%s\n' *.hi *.o *.hs | LC_ALL=C sort + T17171a: '$(RUNGHC)' --ghc-arg=-Wall T17171a.hs T17171b: ===================================== testsuite/tests/runghc/T16145.hs ===================================== @@ -0,0 +1,5 @@ +module T16145 where + +import T16145_aux + +main = g ===================================== testsuite/tests/runghc/T16145.stdout ===================================== @@ -0,0 +1,6 @@ +T16145.hi +T16145.hs +T16145.hs.o +T16145_aux.hi +T16145_aux.hs +T16145_aux.hs.o ===================================== testsuite/tests/runghc/T16145_aux.hs ===================================== @@ -0,0 +1,4 @@ +module T16145_aux where + +g :: IO () +g = return () ===================================== testsuite/tests/runghc/all.T ===================================== @@ -4,6 +4,8 @@ test('T8601', req_interp, makefile_test, []) test('T11247', [req_interp, expect_broken(11247)], makefile_test, []) +test('T16145', req_interp, makefile_test, []) + test('T6132', [], compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c57fa5f1a3fbba72a653dc8ecf2c3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c57fa5f1a3fbba72a653dc8ecf2c3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] Onward [skip ci]
by Simon Peyton Jones (＠simonpj) 02 Apr '26

02 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 5a6fbce9 by Simon Peyton Jones at 2026-04-03T00:52:08+01:00 Onward [skip ci] - - - - - 11 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/HsToCore/ListComp.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -206,7 +206,6 @@ knownKeyOccName std_uniq basicKnownKeyTable :: [(OccName, KnownKeyNameKey)] basicKnownKeyTable = [ (mkTcOcc "Rational", rationalTyConKey) - , (mkTcOcc "Ord", ordClassKey) , (mkTcOcc "Show", showClassKey) , (mkTcOcc "Foldable", foldableClassKey) , (mkTcOcc "Traversable", traversableClassKey) @@ -218,9 +217,18 @@ basicKnownKeyTable , (mkTcOcc "Ix", ixClassKey) , (mkTcOcc "Alternative", alternativeClassKey) - -- Class Eq + -- Class Eq and Ord , (mkTcOcc "Eq", eqClassKey) + , (mkTcOcc "Ord", ordClassKey) , (mkVarOcc "==", eqClassOpKey) + , (mkVarOcc ">=", geClassOpKey) + , (mkVarOcc "<=", leClassOpKey) + , (mkVarOcc "<", ltClassOpKey) + , (mkVarOcc ">", gtClassOpKey) + , (mkVarOcc "compare", compareClassOpKey) + , (mkDataOcc "LT", ordLTDataConKey) + , (mkDataOcc "EQ", ordEQDataConKey) + , (mkDataOcc "GT", ordGTDataConKey) -- Numeric operations , (mkTcOcc "Num", numClassKey) @@ -236,6 +244,7 @@ basicKnownKeyTable -- Class Functor , (mkTcOcc "Functor", functorClassKey) , (mkVarOcc "fmap", fmapClassOpKey) + , (mkVarOcc "map", mapIdKey) -- Class Monad, MonadFix, MonadZip , (mkTcOcc "Monad", monadClassKey) @@ -263,7 +272,7 @@ basicKnownKeyTable , (mkTcOcc "IsString", isStringClassKey) , (mkVarOcc "fromString", fromStringClassOpKey) - -- Stuff for pre-typechecker expansion + -- Records , (mkTcOcc "HasField", hasFieldClassKey) , (mkVarOcc "fromLabel", fromLabelClassOpKey) , (mkVarOcc "getField", getFieldClassOpKey) @@ -420,9 +429,6 @@ basicKnownKeyNames -- Dynamic toDynName, - -- Numeric stuff - geName, - -- Conversion functions ratioTyConName, ratioDataConName, toIntegerName, toRationalName, @@ -458,7 +464,7 @@ basicKnownKeyNames nonEmptyTyConName, -- List operations - mapName, foldrName, buildName, augmentName, + foldrName, buildName, augmentName, -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, @@ -727,6 +733,8 @@ mkMainModule_ m = mkModule mainUnit m * * ************************************************************************ -} +kk_RDR :: KnownKeyNameKey -> RdrName +kk_RDR key = knownKeyRdrName key (knownKeyOccName key) main_RDR_Unqual :: RdrName main_RDR_Unqual = mkUnqual varName (fsLit "main") @@ -735,17 +743,18 @@ main_RDR_Unqual = mkUnqual varName (fsLit "main") ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -ge_RDR = nameRdrName geName -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = nameRdrName ordLTDataConName -eqTag_RDR = nameRdrName ordEQDataConName -gtTag_RDR = nameRdrName ordGTDataConName +eq_RDR = kk_RDR eqClassOpKey +ge_RDR = kk_RDR geClassOpKey +le_RDR = kk_RDR leClassOpKey +lt_RDR = kk_RDR ltClassOpKey +gt_RDR = kk_RDR gtClassOpKey +compare_RDR = kk_RDR compareClassOpKey +ltTag_RDR = kk_RDR ordLTDataConKey +eqTag_RDR = kk_RDR ordEQDataConKey +gtTag_RDR = kk_RDR ordGTDataConKey map_RDR :: RdrName -map_RDR = nameRdrName mapName +map_RDR = kk_RDR mapIdKey foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName @@ -906,7 +915,7 @@ uWordHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") (fsLit " fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, mappend_RDR :: RdrName -fmap_RDR = nameRdrName fmapName +fmap_RDR = kk_RDR fmapClassOpKey replace_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$") pure_RDR = nameRdrName pureAName ap_RDR = nameRdrName apAName @@ -951,7 +960,7 @@ runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey -ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey @@ -1029,12 +1038,6 @@ unpackCStringName, unpackCStringUtf8Name :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey --- Base classes (Eq, Ord, Functor) -fmapName, geName, functorClassName :: Name -geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_INTERNAL_BASE (fsLit "Functor") functorClassKey -fmapName = varQual gHC_INTERNAL_BASE (fsLit "fmap") fmapClassOpKey - -- Class Monad thenMName, bindMName, returnMName :: Name thenMName = varQual gHC_INTERNAL_BASE (fsLit ">>") thenMClassOpKey @@ -1076,14 +1079,13 @@ considerAccessibleName = varQual gHC_MAGIC (fsLit "considerAccessible") consider -- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName, - mapName, assertName, + assertName, dollarName :: Name dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_INTERNAL_BASE (fsLit "foldr") foldrIdKey buildName = varQual gHC_INTERNAL_BASE (fsLit "build") buildIdKey augmentName = varQual gHC_INTERNAL_BASE (fsLit "augment") augmentIdKey -mapName = varQual gHC_INTERNAL_BASE (fsLit "map") mapIdKey assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey @@ -2063,7 +2065,7 @@ rootMainKey, runMainKey :: KnownKeyNameKey rootMainKey = mkPreludeMiscIdUnique 101 runMainKey = mkPreludeMiscIdUnique 102 -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: KnownKeyNameKey +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: KnownKeyNameKey thenIOIdKey = mkPreludeMiscIdUnique 103 lazyIdKey = mkPreludeMiscIdUnique 104 assertErrorIdKey = mkPreludeMiscIdUnique 105 @@ -2096,52 +2098,53 @@ rationalToFloatIdKey, rationalToDoubleIdKey :: KnownKeyNameKey rationalToFloatIdKey = mkPreludeMiscIdUnique 132 rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 -seqHashKey = mkPreludeMiscIdUnique 134 - -coerceKey :: KnownKeyNameKey -coerceKey = mkPreludeMiscIdUnique 157 -{- -Certain class operations from Prelude classes. They get their own -uniques so we can look them up easily when we want to conjure them up -during type checking. --} +seqHashKey, coerceKey :: KnownKeyNameKey +seqHashKey = mkPreludeMiscIdUnique 134 +coerceKey = mkPreludeMiscIdUnique 135 -- Just a placeholder for unbound variables produced by the renamer: unboundKey :: KnownKeyNameKey -unboundKey = mkPreludeMiscIdUnique 158 +unboundKey = mkPreludeMiscIdUnique 136 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey :: KnownKeyNameKey -fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 -minusClassOpKey = mkPreludeMiscIdUnique 161 -fromRationalClassOpKey = mkPreludeMiscIdUnique 162 -enumFromClassOpKey = mkPreludeMiscIdUnique 163 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 -enumFromToClassOpKey = mkPreludeMiscIdUnique 165 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 -eqClassOpKey = mkPreludeMiscIdUnique 167 -geClassOpKey = mkPreludeMiscIdUnique 168 -negateClassOpKey = mkPreludeMiscIdUnique 169 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) 02L -thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 173 -returnMClassOpKey = mkPreludeMiscIdUnique 174 +fromIntegerClassOpKey = mkPreludeMiscIdUnique 140 +minusClassOpKey = mkPreludeMiscIdUnique 141 +fromRationalClassOpKey = mkPreludeMiscIdUnique 142 +enumFromClassOpKey = mkPreludeMiscIdUnique 143 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 144 +enumFromToClassOpKey = mkPreludeMiscIdUnique 145 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 146 + +eqClassOpKey = mkPreludeMiscIdUnique 147 +geClassOpKey = mkPreludeMiscIdUnique 148 +leClassOpKey = mkPreludeMiscIdUnique 149 +ltClassOpKey = mkPreludeMiscIdUnique 150 +gtClassOpKey = mkPreludeMiscIdUnique 151 +compareClassOpKey = mkPreludeMiscIdUnique 152 + + +negateClassOpKey = mkPreludeMiscIdUnique 153 +bindMClassOpKey = mkPreludeMiscIdUnique 154 +thenMClassOpKey = mkPreludeMiscIdUnique 155 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 156 +returnMClassOpKey = mkPreludeMiscIdUnique 157 -- Recursive do notation mfixIdKey :: KnownKeyNameKey -mfixIdKey = mkPreludeMiscIdUnique 175 +mfixIdKey = mkPreludeMiscIdUnique 158 -- MonadFail operations failMClassOpKey :: KnownKeyNameKey -failMClassOpKey = mkPreludeMiscIdUnique 176 +failMClassOpKey = mkPreludeMiscIdUnique 159 -- fromLabel fromLabelClassOpKey :: KnownKeyNameKey -fromLabelClassOpKey = mkPreludeMiscIdUnique 177 +fromLabelClassOpKey = mkPreludeMiscIdUnique 160 -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, @@ -2180,6 +2183,7 @@ ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: KnownKeyNameKey isListClassKey = mkPreludeMiscIdUnique 198 fromListClassOpKey = mkPreludeMiscIdUnique 199 + fromListNClassOpKey = mkPreludeMiscIdUnique 500 toListClassOpKey = mkPreludeMiscIdUnique 501 ===================================== compiler/GHC/HsToCore/ListComp.hs ===================================== @@ -118,7 +118,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM -- Create an unzip function for the appropriate arity and element types and find "map" unzip_stuff' <- mkUnzipBind form from_bndrs_tys - map_id <- dsLookupGlobalId mapName + map_id <- dsLookupKnownKeyId mapIdKey -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -27,7 +27,7 @@ module GHC.HsToCore.Monad ( dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, - dsLookupKnownKey, dsLookupKnownKeyTyCon, dsLookupKnownKeyId, + dsLookupKnownKeyTyCon, dsLookupKnownKeyId, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, @@ -563,13 +563,26 @@ mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal -dsLookupKnownKey :: KnownKeyNameKey -> DsM TyThing -dsLookupKnownKey uniq +dsGetKnownKeySource :: DsM KnownKeyNameSource +dsGetKnownKeySource = do { rebindable_path <- goptM Opt_RebindableKnownKeyNames - ; mb_rdr_env <- if rebindable_path - then do { rdr_env <- dsGetGlobalRdrEnv - ; return (KKNS_InScope rdr_env) } - else return KKNS_FromModule + ; if rebindable_path + then do { rdr_env <- dsGetGlobalRdrEnv + ; return (KKNS_InScope rdr_env) } + else return KKNS_FromModule } + +dsLookupKnownKeyName :: KnownKeyNameKey -> DsM Name +dsLookupKnownKeyName uniq + = do { rebindable_path <- dsGetKnownKeySource + ; dsToIfL $ + do { mb_res <- lookupKnownKeyName mb_rdr_env uniq + ; case mb_res of + Succeeded name -> return name + Failed msg -> failIfM (pprDiagnostic msg) } } + +dsLookupKnownKeyThing :: KnownKeyNameKey -> DsM TyThing +dsLookupKnownKeyThing uniq + = do { rebindable_path <- dsGetKnownKeySource ; dsToIfL $ do { mb_res <- lookupKnownKeyThing mb_rdr_env uniq ; case mb_res of @@ -578,11 +591,11 @@ dsLookupKnownKey uniq dsLookupKnownKeyTyCon :: KnownKeyNameKey -> DsM TyCon dsLookupKnownKeyTyCon uniq - = tyThingTyCon <$> dsLookupKnownKey uniq + = tyThingTyCon <$> dsLookupKnownKeyThing uniq dsLookupKnownKeyId :: KnownKeyNameKey -> DsM Id dsLookupKnownKeyId uniq - = tyThingId <$> dsLookupKnownKey uniq + = tyThingId <$> dsLookupKnownKeyThing uniq dsLookupGlobal :: Name -> DsM TyThing -- Very like GHC.Tc.Utils.Env.tcLookupGlobal ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -2315,9 +2315,14 @@ lookupOccDsM n globalVar :: Name -> DsM (Core TH.Name) globalVar n = case nameModule_maybe n of - Just m -> globalVarExternal m (getOccName n) + Just m -> globalVarExternal m (getOccName n) Nothing -> globalVarLocal (getUnique n) (getOccName n) +globalKnownKey :: KnonwKeyNameKey -> DsM (Core TH.Name) +globalKnownKey key + = do { name <- dsLookupKnownKeyName key + ; globalVar name } + globalVarLocal :: Unique -> OccName -> DsM (Core TH.Name) globalVarLocal unique name = do { MkC occ <- occNameLit name @@ -3150,7 +3155,8 @@ repRdrName rdr_name = do occ <- occNameLit occ repNameQ mod occ Orig m n -> lift $ globalVarExternal m n - Exact n -> lift $ globalVar n + Exact (ExactName n) -> lift $ globalVar n + Exact (ExactKey key _) -> lift $ globalKnownKey key repNameS :: Core String -> MetaM (Core TH.Name) repNameS (MkC name) = rep2_nw mkNameSName [name] ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -864,7 +864,9 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns +setRdrNameSpace (Exact (ExactKey k o)) ns -- Highly suspicious + = Exact (ExactKey k (setOccNameSpace ns o)) +setRdrNameSpace (Exact (ExactName n)) ns | Just thing <- wiredInNameTyThing_maybe n = setWiredInNameSpace thing ns -- Preserve Exact Names for wired-in things, @@ -875,7 +877,7 @@ setRdrNameSpace (Exact n) ns | otherwise -- This can happen when quoting and then -- splicing a fixity declaration for a type - = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + = nameRdrName (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) where occ = setOccNameSpace ns (nameOccName n) @@ -884,13 +886,13 @@ setWiredInNameSpace (ATyCon tc) ns | isDataConNameSpace ns = ty_con_data_con tc | isTcClsNameSpace ns - = Exact (getName tc) -- No-op + = nameRdrName (getName tc) -- No-op setWiredInNameSpace (AConLike (RealDataCon dc)) ns | isTcClsNameSpace ns = data_con_ty_con dc | isDataConNameSpace ns - = Exact (getName dc) -- No-op + = nameRdrName (getName dc) -- No-op setWiredInNameSpace thing ns = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) @@ -899,10 +901,10 @@ ty_con_data_con :: TyCon -> RdrName ty_con_data_con tc | isTupleTyCon tc , Just dc <- tyConSingleDataCon_maybe tc - = Exact (getName dc) + = nameRdrName (getName dc) | tc `hasKey` listTyConKey - = Exact nilDataConName + = nameRdrName nilDataConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace srcDataName (getOccName tc)) @@ -911,10 +913,10 @@ data_con_ty_con :: DataCon -> RdrName data_con_ty_con dc | let tc = dataConTyCon dc , isTupleTyCon tc - = Exact (getName tc) + = nameRdrName (getName tc) | dc `hasKey` nilDataConKey - = Exact listTyConName + = nameRdrName listTyConName | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace tcClsName (getOccName dc)) ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -485,8 +485,13 @@ data ExactOrOrigResult -- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult lookupExactOrOrig_base rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code + | Just n <- rdrNameExactName_maybe rdr_name -- This happens in derived code = cvtEither <$> lookupExactOcc_either n + + | Just key <- exactKeyRdr_maybe rdr_name + = do { name <- rnLookupKnownKeyName key + ; cvtEither <$> lookupExactOcc_either name } + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { nm <- lookupOrig rdr_mod rdr_occ @@ -499,6 +504,7 @@ lookupExactOrOrig_base rdr_name ; return $ case mb_gre of Left err -> ExactOrOrigError err Right gre -> FoundExactOrOrig gre } + | otherwise = return NotExactOrOrig where cvtEither (Left e) = ExactOrOrigError e ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -1656,17 +1656,17 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon as_needed = take con_arity as_RDRs lift_Expr = mk_bracket finish con_brack :: LHsExpr GhcPs - con_brack = nlHsApps (Exact conEName) + con_brack = nlHsApps (nameRdrName conEName) [noLocA $ HsUntypedBracket noExtField - $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))] + $ VarBr noSrcSpanA True (noLocA (nameRdrName (dataConName data_con)))] - finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed) + finish = foldl' (\b1 b2 -> nlHsApps (nameRdrName appEName) [b1, b2]) con_brack (map lift_var as_needed) lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed) lift_var x = nlHsPar (mk_lift_expr x) mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed) - mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x] + mk_lift_expr x = nlHsApps (nameRdrName liftName) [nlHsVar x] {- ************************************************************************ @@ -2612,7 +2612,7 @@ new_dc_deriv_rdr_name loc dc occ_fun newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName newAuxBinderRdrName loc parent occ_fun = do uniq <- newUnique - pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc + pure $ nameRdrName $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc -- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@ -- whose return types match when checked against @tycon_args@. ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1552,12 +1552,12 @@ instance TH.Quasi TcM where = addErr $ TcRnTHError $ AddTopDeclsError $ InvalidTopDecl d bindName :: RdrName -> TcM () - bindName (Exact n) + bindName rdr_name + | Just n <- rdrNameExactName_maybe rdr_nname = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) } + | otherwise + = addErr $ TcRnTHError $ THNameError $ NonExactName rdr_name qAddForeignFilePath lang fp = do var <- fmap tcg_th_foreign_files getGblEnv ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -1889,7 +1889,7 @@ cvtTypeKind typeOrKind ty hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs hsTypeToArrow w = case unLoc w of - HsTyVar _ _ (L _ (isExact_maybe -> Just n)) + HsTyVar _ _ (L _ (rdrNameExactName_maybe -> Just n)) | n == oneDataConName -> HsLinearAnn noAnn | n == manyDataConName -> HsUnannotated (EpArrow noAnn) _ -> HsExplicitMult (noAnn, EpArrow noAnn) w @@ -2319,7 +2319,7 @@ thOrigOrExactRdrName occ th_ns pkg mod = knownOrigToExactRdrName (thOrigRdrName knownOrigToExactRdrName :: RdrName -> RdrName knownOrigToExactRdrName (Orig mod occ) | Just name <- isKnownOrigName_maybe mod occ - = Exact name + = nameRdrName name knownOrigToExactRdrName rdr = rdr -- Return an exact RdrName if we're dealing with built-in syntax. ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -26,18 +26,20 @@ module GHC.Types.Name.Reader ( -- * The main type RdrName(..), -- Constructors exported only to GHC.Iface.Binary + ExactRdrName(..), -- ** Construction mkRdrUnqual, mkRdrQual, mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, + nameRdrName, knownKeyRdrName, getRdrName, -- ** Destruction rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTcCls, demoteRdrNameTv, promoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + isOrig, isOrig_maybe, isExact, + rdrNameExactName_maybe, rdrNameKnownKey_maybe, isSrcRdrName, -- ** Preserving user-written qualification WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, @@ -196,7 +198,7 @@ data RdrName -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' - | Exact ExactSpec + | Exact ExactRdrName -- ^ Exact name -- -- We know exactly the 'Name'. This is used: @@ -209,9 +211,14 @@ data RdrName -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data -data ExactSpec - = ExactName Name -- Use this when you know the exact Name - | ExactKey KnownKeyNameKey -- Use this for known-key names +data ExactRdrName + = ExactName -- Use this when you know the exact Name + Name + + | ExactKey -- Use this for known-key names + KnownKeyNameKey + OccName -- This OccName corresponds to the key + deriving Data {- @@ -229,7 +236,8 @@ rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name +rdrNameOcc (Exact (ExactName name)) = nameOccName name +rdrNameOcc (Exact (ExactKey _ occ)) = occ rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc @@ -291,16 +299,19 @@ mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) +knownKeyRdrName :: KnownKeyNameKey -> OccName -> RdrName +knownKeyRdrName key occ = Exact (ExactKey key occ) + nameRdrName :: Name -> RdrName nameRdrName name = Exact (ExactName name) -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) +-- nukeExact :: Name -> RdrName +-- nukeExact n +-- | isExternalName n = Orig (nameModule n) (nameOccName n) +-- | otherwise = Unqual (nameOccName n) isRdrDataCon :: RdrName -> Bool isRdrTyVar :: RdrName -> Bool @@ -339,9 +350,13 @@ isExact :: RdrName -> Bool isExact (Exact _) = True isExact _ = False -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing +rdrNameExactName_maybe :: RdrName -> Maybe Name +rdrNameExactName_maybe (Exact (ExactName n)) = Just n +rdrNameExactName_maybe _ = Nothing + +rdrNameKnownKey_maybe :: RdrName -> Maybe KnownKeyNameKey +rdrNameKnownKey_maybe (Exact (ExactKey k _)) = Just k +rdrNameKnownKey_maybe _ = Nothing {- ************************************************************************ @@ -352,7 +367,8 @@ isExact_maybe _ = Nothing -} instance Outputable RdrName where - ppr (Exact name) = ppr name + ppr (Exact (ExactName name)) = ppr name + ppr (Exact (ExactKey key occ)) = ppr occ <> braces (pprKnownKey key) ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) @@ -364,16 +380,28 @@ instance OutputableBndr RdrName where pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name + | Just name <- rdrNameExactName_maybe rdr = pprPrefixName name -- pprPrefixName has some special cases, so -- we delegate to them rather than reproduce them | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) +instance Eq ExactRdrName where + (ExactName n1) == (ExactName n2) = n1==n2 + (ExactKey k1 _) == (ExactKey k2 _) = k1==k2 + _ == _ = False + +instance Ord ExactRdrName where + (ExactName n1) `compare` (ExactName n2) = n1 `compare` n2 + (ExactName {}) `compare` (ExactKey {}) = LT + (ExactKey {}) `compare` (ExactName {}) = GT + (ExactKey k1 _) `compare` (ExactKey k2 _) = k1 `nonDetCmpUnique` k2 + instance Eq RdrName where (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 +-- (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 +-- r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 @@ -471,7 +499,7 @@ lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr = lookupOccEnv env occ -- See Note [Local bindings with Exact Names] - | Exact name <- rdr + | Just name <- rdrNameExactName_maybe rdr , name `elemNameSet` ns = Just name @@ -492,8 +520,9 @@ lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Unqual occ -> occ `elemOccEnv` env + Exact (ExactName name) -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Exact (ExactKey{}) -> False Qual {} -> False Orig {} -> False ===================================== compiler/GHC/Types/Unique.hs ===================================== @@ -67,6 +67,7 @@ import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) import GHC.Word ( Word64 ) import Data.Char ( chr, ord, isPrint ) +import Data.Data ( Data ) import Language.Haskell.Syntax.Module.Name @@ -128,6 +129,7 @@ Prefer `env_ut :: Char` and -- -- These are sometimes also referred to as \"keys\" in comments in GHC. newtype Unique = MkUnique Word64 + deriving Data -- Needed only because KnownKeyNameKey is in RdrName data UniqueTag = AlphaTyVarTag View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a6fbce9a799ad24d05b864f43ddc5b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5a6fbce9a799ad24d05b864f43ddc5b… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ani/precise-fun-loc
by Apoorv Ingle (＠ani) 02 Apr '26

02 Apr '26

Apoorv Ingle pushed new branch wip/ani/precise-fun-loc at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ani/precise-fun-loc You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 12 commits: Streamline expansions using HsExpansion (#25001)
by Marge Bot (＠marge-bot) 02 Apr '26

02 Apr '26

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 58009c14 by Apoorv Ingle at 2026-04-02T09:51:24+01:00 Streamline expansions using HsExpansion (#25001) Notes added [Error Context Stack] [Typechecking by expansion: overview] Notes updated Note [Expanding HsDo with XXExprGhcRn] [tcApp: typechecking applications] ------------------------- Metric Decrease: T9020 ------------------------- There are 2 key changes: 1. `HsExpand` datatype mediates between expansions 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` This has some consequences detailed below: 1. `HsExpand` datatype mediates between expansions * Simplifies the implementations of `tcExpr` to work on `XExpr` * Removes `VACtxt` (and its associated `VAExpansion` and `VACall`) datatype, it is subsumed by simply a `SrcSpan`. * Removes the function `addHeadCtxt` as it is now mearly setting a location * The function `tcValArgs` does its own argument number management * move `splitHsTypes` out of `tcApp` * Removes special case of tcBody from `tcLambdaMatches` * Removes special case of `dsExpr` for `ExpandedThingTc` * Renames `tcMonoExpr` -> `tcMonoLExpr`, `tcMonoExprNC` -> `tcMonoLExpr` * Renames `EValArg`, `EValArgQL` fields: `ea_ctxt` -> `ea_loc_span` and `eaql_ctx` -> `eaql_loc_span` * Remove `PopErrCtxt` from `XXExprGhcRn` * `fun_orig` in tcInstFun depends on the SrcSpan of the head of the application chain (similar to addArgCtxt) - it references the application chain head if it is user located, or uses the error context stack as a fallback if it's a generated location * Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - Expressions wrapped around `GeneratedSrcSpan` are ignored and never added to the error context stack - In Explicit list expansion `fromListN` is wrapped with a `GeneratedSrcSpan` with `GeneratedSrcSpanDetails` field to store the original srcspan 2. Replace `ErrCtxtM` to a simpler `HsCtxt` that does not depend on a `TidyEnv` * Merge `HsThingRn` to `HsCtxt` * Landmark Error messages are now just computed on the fly * Make HsExpandedRn and HsExpandedTc payload a located HsExpr GhcRn * `HsCtxt` are tidied and zonked at the end right before printing Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 9d964ec9 by Zubin Duggal at 2026-04-02T16:15:51-04:00 driver: recognise .dyn_o as a valid object file to link if passed on the command line. This allows plugins compiled with this suffix to run. Fixes #24486 - - - - - 117f299b by Simon Jakobi at 2026-04-02T16:15:54-04:00 Add regression test for #16145 Closes #16145. - - - - - 87807fc2 by Matthew Pickering at 2026-04-02T16:15:55-04:00 bytecode: Add magic header/version to bytecode files In order to avoid confusing errors when using stale interface files (ie from an older compiler version), we add a simple header/version check like the one for interface files. Fixes #27068 - - - - - 2d653e6a by fendor at 2026-04-02T16:15:55-04:00 Add constants for bytecode in-memory buffer size Introduce a common constant for the default size of the .gbc and .bytecodelib binary buffer. The buffer is by default set to 1 MB. - - - - - e28fd7fc by Duncan Coutts at 2026-04-02T16:15:56-04:00 Add a rts posix FdWakup utility module This will be used to implement wakeupIOManager for in-RTS I/O managers. It provides a notification/wakeup mechanism using FDs, suitable for situations when a thread is blocked on a set of fds anyway. It uses the classic self-pipe trick, or equivalently eventfd on supported platforms. This will initially be used to implement prompt interrupt or shutdown of the posix ticker thread. - - - - - 85199690 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Add prompt shutdown to the pthread ticker implementation. The Linux timerfd ticker monitors a pipe which is used by exitTicker to ensure a prompt wakeup and shutdown. The pthread ticker lacked this and so would only exit at the next ticker wakeup (10ms by default). This patch adds the same mechanism to the pthread ticker. This changes the pthread ticker from waiting by using nanosleep() to waiting using either ppoll() or select(), so that it can wait on both a time and a file descriptor. On Linux at least, a test program to compare the timing jitter of these APIs shows that using nanpsleep, ppoll or select makes no statistical difference to the maximum or average jitter. This is a step towards unifying the posix ticker implementations, so that we can have just one portable one (albeit with some limited cpp). It is also a step towards using the ticker as part of a more general implementation of wakeUpRts, since this will require a method to wake the rts from a signal handler context (ctl-c handler). - - - - - bd6e5d21 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Update ticker header commentary It was antique and didn't apply even to the previous implementation, and certainly not to the updated one. - - - - - 4286c294 by Duncan Coutts at 2026-04-02T16:15:56-04:00 Remove the timerfd-based ticker implementation There does not appear to be any remaining advantage on Linux to using the timerfd ticker implementation over the portable one (using ppoll on Linux for precise timing). The eventfd implementation was originally added at a time when Linux was still using a signal based implementation. So it made sense at the time. See (closed) issue #10840. - - - - - 6bf4326a by Duncan Coutts at 2026-04-02T16:15:56-04:00 Consolidate to a single posix ticker implementation Previously we had four implementations, two using signals and two using threads. Having just one should make behaviour more consistent between platforms, and should make maintenance easier. - - - - - 93344577 by mangoiv at 2026-04-02T16:15:57-04:00 issue template: fix add bug label - - - - - 5c57fa5f by Sylvain Henry at 2026-04-02T16:16:28-04:00 Add more canned GC functions for common register patterns (#27142) Based on analysis of heap-check sites across the GHC compiler and Cabal, the following patterns were not covered by existing canned GC functions but occurred frequently enough to warrant specialisation: stg_gc_ppppp -- 5 GC pointers stg_gc_ip -- unboxed word + GC pointer stg_gc_pi -- GC pointer + unboxed word stg_gc_ii -- two unboxed words stg_gc_bpp -- byte (I8) + two GC pointers Adding these reduces the fraction of heap-check sites falling back to the generic GC path from ~1.4% to ~0.4% when compiling GHC itself. Co-Authored-By: Claude Sonnet 4.6 <noreply(a)anthropic.com> - - - - - 142 changed files: - .gitlab/issue_templates/default.md - compiler/GHC.hs - compiler/GHC/ByteCode/Serialize.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Expr.hs-boot - compiler/GHC/Hs/Instances.hs - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/StgToCmm/Heap.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Do.hs - + compiler/GHC/Tc/Gen/Expand.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Expr.hs-boot - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/HsType.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Error.hs - + compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - + compiler/GHC/Unit/State.hs-boot - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - compiler/ghc.cabal.in - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - rts/HeapStackCheck.cmm - rts/RtsSymbols.c - rts/include/stg/MiscClosures.h - + rts/posix/FdWakeup.c - + rts/posix/FdWakeup.h - rts/posix/Ticker.c - − rts/posix/ticker/Pthread.c - − rts/posix/ticker/TimerFd.c - rts/rts.cabal - testsuite/tests/count-deps/CountDepsAst.stdout - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/bytecode-object/Makefile - testsuite/tests/driver/bytecode-object/all.T - testsuite/tests/ghci/prog-mhu001/prog-mhu001c.stdout - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - testsuite/tests/monadfail/MonadFailErrors.stderr - testsuite/tests/overloadedrecflds/should_fail/T26480b.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail11.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail9.stderr - testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr - testsuite/tests/plugins/Makefile - + testsuite/tests/plugins/T24486-plugin/Makefile - + testsuite/tests/plugins/T24486-plugin/Setup.hs - + testsuite/tests/plugins/T24486-plugin/T24486-plugin.cabal - + testsuite/tests/plugins/T24486-plugin/T24486_Plugin.hs - + testsuite/tests/plugins/T24486.hs - + testsuite/tests/plugins/T24486_Helper.hs - testsuite/tests/plugins/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/printer/T17697.stderr - testsuite/tests/profiling/should_run/callstack001.stdout - testsuite/tests/rebindable/rebindable6.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/runghc/Makefile - + testsuite/tests/runghc/T16145.hs - + testsuite/tests/runghc/T16145.stdout - + testsuite/tests/runghc/T16145_aux.hs - testsuite/tests/runghc/all.T - + testsuite/tests/typecheck/should_compile/ExpansionQLIm.hs - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T6069.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T7857.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail140.stderr - testsuite/tests/typecheck/should_fail/tcfail181.stderr - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82c991ca1ea5fa9c70a3f7986af9ab… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/82c991ca1ea5fa9c70a3f7986af9ab… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/jeltsch/more-efficient-home-module-finding
by Wolfgang Jeltsch (＠jeltsch) 02 Apr '26

02 Apr '26

Wolfgang Jeltsch pushed new branch wip/jeltsch/more-efficient-home-module-finding at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/jeltsch/more-efficient-home-m… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26878] Simplify mkTick
by sheaf (＠sheaf) 02 Apr '26

02 Apr '26

sheaf pushed to branch wip/T26878 at Glasgow Haskell Compiler / GHC Commits: e0a32431 by sheaf at 2026-04-02T22:12:24+02:00 Simplify mkTick This commit simplifies 'GHC.Core.Utils.mkTick', removing the accumulating parameter 'rest' which was suspiciously treating a bunch of different ticks as a group, and moving the group as a whole around the AST, ignoring that the ticks in the group might have different placement properties. Also adds Note [Pushing SCCs inwards] which clarifies the logic for pushing SCCs into lambdas, constructor applications, and dropping SCCs around non-function variables (in particular the treatment of splittable ticks). A few other changes are also implemented: - simplify 'can_split' predicate (no functional change) - drop profiling ticks around coercions, fixing #26941 and #27121 - combine profiling ticks into one when possible Fixes #26878, #26941 and #27121 Co-authored-by: simonpj <simon.peytonjones(a)gmail.com> - - - - - 9 changed files: - compiler/GHC/Core/Utils.hs - compiler/GHC/Types/Tickish.hs - libraries/ghc-heap/tests/tso_and_stack_closures.hs - + testsuite/tests/profiling/should_compile/T27121.hs - + testsuite/tests/profiling/should_compile/T27121_aux.hs - testsuite/tests/profiling/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26941.hs - + testsuite/tests/simplCore/should_compile/T26941_aux.hs - testsuite/tests/simplCore/should_compile/all.T Changes: ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -303,101 +303,262 @@ mkCast expr co * * ********************************************************************* -} --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. +-- | Wraps the given expression in a Tick, floating the tick as far into +-- the AST as possible in order to try to satisfy the tick's desired placement +-- properties (as per Note [Tickish placement] in GHC.Types.Tickish). +-- +-- Prefer using 'mkTick' over explicit use of the 'Tick' constructor. +-- +-- Also performs small on-the-fly optimisations: +-- +-- * Eliminate unnecessary ticks by either absorbing them into existing ones +-- or dropping them if that is valid (e.g. dropping profiling ticks around +-- types, coercions and literals). +-- * Split profiling ticks into counting/scoping parts so that the two parts +-- can be placed independently into the AST. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id orig_expr +mkTick t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. - canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + -- See Note [Scoping ticks and counting ticks] in GHC.Types.Tickish. + can_split = tickishCanSplit t - -- mkTick' handles floating of ticks *into* the expression. - mkTick' :: (CoreExpr -> CoreExpr) -- Apply before adding tick (float with) - -- Always a composition of (Tick t) wrappers - -> CoreExpr -- Current expression - -> CoreExpr - -- So in the call (mkTick' rest e), the expression - -- (rest e) - -- has the same type as e - -- Returns an expression equivalent to (Tick t (rest e)) - mkTick' rest expr = case expr of - -- Float ticks into unsafe coerce the same way we would do with a cast. - Case scrut bndr ty alts@[Alt ac abs _rhs] - | Just rhs <- isUnsafeEqualityCase scrut bndr alts - -> Case scrut bndr ty [Alt ac abs (mkTick' rest rhs)] - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. + -- mkTick' handles floating of tick `t` *into* the expression. + mkTick' :: CoreExpr -> CoreExpr + mkTick' expr = case expr of Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> Tick t2 $ mkTick' rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' rest e -- Drop t2 - | tickishContains t2 t -> rest e -- Drop t - | otherwise -> mkTick' (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkCast (mkTick' rest e) co - Coercion co -> Tick t $ rest (Coercion co) + + -- Common up ticks when possible, including profiling ticks that + -- share a cost centre and source notes that subsume one another. + | Just t' <- combineTickish_maybe t t2 + -> mkTick t' e + + -- Profiling ticks for different cost centres should never be reordered + -- relative to each other. Therefore, we stop whenever two collide. + | ProfNote {} <- t + , ProfNote {} <- t2 + -> Tick t expr + + -- Ticks of different placements float through each other, so that each + -- tick can be floated into its expected position in the AST. + -- See Note [Tickish placement] in GHC.Types.Tickish. + | tickishPlace t2 /= tickishPlace t + -> Tick t2 $ mkTick' e Lam x e -- Always float through type lambdas. Even for non-type lambdas, -- floating is allowed for all but the most strict placement rule. | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> Lam x $ mkTick' rest e + -> Lam x $ mkTick' e - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + -- Push SCCs into lambdas. + -- See (PSCC2) in Note [Pushing SCCs inwards]. + | can_split + -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e App f arg - -- Always float through type applications. + -- All ticks float inwards through non-runtime arguments, as per + -- Note [Tickish placement] in GHC.Types.Tickish. | not (isRuntimeArg arg) - -> App (mkTick' rest f) arg + -> App (mkTick' f) arg - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -- Push SCCs into saturated constructor applications. + -- See (PSCC3) in Note [Pushing SCCs inwards]. + | isSaturatedConApp expr + , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre - then rest $ tickHNFArgs t expr - else Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + then tickHNFArgs t expr + else Tick (mkNoScope t) $ tickHNFArgs (mkNoCount t) expr + + -- See Note [No ticks around types or coercions] + e@(Coercion {}) -> e + e@(Type {}) -> e + -- Don't wrap static data in a tick which compiles to code, + -- as the code will never be run. + e@(Lit {}) | tickishIsCode t -> e + + -- All ticks can be floated through casts, as per Note [Tickish placement]. + Cast e co -> mkCast (mkTick' e) co + + -- Treat 'unsafeCoerce' as if it was a cast: float all ticks inwards. + -- See Note [Push ticks into unsafeCoerce] + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> Case scrut bndr ty [Alt ac abs (mkTick' rhs)] Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t - | notFunction && canSplit - -> Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} + -- Don't drop any ticks around a function + | isFunTy (idType x) + -> Tick t expr + -- Drop SCCs around non-function variables. + -- See (PSCC1) in Note [Pushing SCCs inwards]. | tickishPlace t == PlaceCostCentre - -> rest expr -- Drop t + -> -- Drop pure SCC ticks: scc<foo> (x :: Int) ==> x + expr + | can_split + -> -- Drop the scoping part of the tick, but keep the counting part. + Tick (mkNoScope t) expr + + -- Catch-all: annotate where we stand. + -- In particular (but not only): Let, most Cases. + _other -> Tick t expr + +{- Note [Pushing SCCs inwards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Amongst all ticks, SCCs have the laxest placement properties (PlaceCostCentre, +as described in Note [Tickish placement] GHC.Types.Tickish): + + (PSCC1) SCCs around non-function variables can be eliminated. + The cost of evaluating the variable will be attributed to its definition + site, so the SCC makes no difference. Example: + + scc<foo> (x :: Int) ==> x + + NB: this is only valid when the variable is not a function. For example, in: + + scc<foo> (f :: Int -> Int) + + we must retain the cost centre annotation, as it affects the cost-centre + pointer when the function is called. Discarding the SCC in this case would + defeat the profiling mechanism entirely! + + (PSCC2) SCCs can be pushed into lambdas. + + scc<foo> (\x -> e) ==> \x -> scc<foo> e + + (PSCC3) We can push SCCs into (saturated) constructor applications. + For example, for an arity 2 data constructor 'D': + + scc<foo> (D e1 e2) ==> D (scc<foo> e1) (scc<foo> e2) + +Now, two kinds of ticks contain SCCs: + + - bare SCCs (i.e. ProfNote with profNoteCounts = False, profNoteScopes = True) + - profiling ticks that both count and scope + +The above explanation deals with bare SCCs. When handling profiling ticks that +both count and scope, we can split tick into two, so that the scoping part can +be pushed inwards (or even discarded). Specifically, we perform the following +transformations: + + (PSCC1) Drop the SCC around non-function variables, keeping only the counting + part: + + scctick<foo> (x :: Int) ==> tick<foo> x + + (PSCC2) Push the SCC inside lambdas: + + scctick<foo> (\x. e) ==> tick<foo> (\x. scc<foo> e) + + NB: we must keep the counting part outside the lambda, in order to preserve + tick counter tallies – it would not be sound to push the counting part inside. - -- Catch-all: Annotate where we stand - _any -> Tick t $ rest expr + (PSCC3) Push the SCC inside saturated contructor applications. + + scctick<foo> (D e1 e2) ==> tick<foo> (D (scc<foo> e1) (scc<foo> e2)) + +The benefit of these transformation is that the counting part, tick<foo>, can +likely be floated out of the way, which may expose additional optimisation +opportunities. For example, for (PSCC2): + + (scctick<foo> (\x. e)) arg + + ==>{PSCC2} + + (tick<foo> (\x. scc<foo> e)) arg + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> ((\x. scc<foo> e) arg) + + ==>{beta reduction} + + tick<foo> (let x = arg in scc<foo> e) + +For (PSCC3): + + case (scctick<foo> (Just x)) of { Nothing -> 0; Just y -> y + 1 } + + ==>{PSCC3} + + case (tick<foo> (Just (scc<foo> x))) of { Nothing -> 0; Just y -> y + 1 } + + ==>{GHC.Core.Opt.FloatOut.floatExpr, because 'tick<foo>' has no scope} + + tick<foo> (case Just (scc<foo> x) of { Nothing -> 0; Just y -> y + 1 }) + + ==>{case of known constructor} + + tick<foo> (let y = scc<foo> x in y + 1) + +Note [Push ticks into unsafeCoerce] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #25212, we had a program of the form: + + data Box = Box Any + asBox :: a -> Box + asBox x = {-# SCC asBox #-} Box (unsafeCoerce x) + +As per Note [Implementing unsafeCoerce] in GHC.Internal.Unsafe.Coerce, the call +to `unsafeCoerce` turns into + + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + +The worker for 'asBox' is then of the form: + + $wasBox = \@a (x :: a) -> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +When inserting the SCC, we push it into the constructor as per (PSCC3) in +Note [Pushing SCCs inwards], so we get: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# scc<asBox> + case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> x |> Sub co + #) + +Now, if we don't push the SCC tick into the case statement, Core Prep will +see an expression like 'MkSolo# (scc<asBox> ...)', which it will ANFise to +'let x = scc<asBox> ... in MkSolo# x', creating an unwanted thunk in the process. + +So the strategy is to treat this 'unsafeEqualityProof' case statement as if it +was a cast. We thus push the SCC into the RHS of the pattern match: + + $wasBox = \@a (x :: a) -> + tick<asBox> + (# case unsafeEqualityProof @Type @a @Any of + UnsafeRefl (co :: a ~# Any) -> scc<asBox> x |> Sub co + #) + +Then the SCC completely evaporates, as per (PSCC1) in Note [Pushing SCCs inwards]. + +Note [No ticks around types or coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It doesn't make much sense to put a tick around a type or a coercion, as both +types and coercions are erased in the end. + +In fact, it is quite dangerous to add a tick around types or coercions, because +the optimiser does not robustly look through ticks: + + - 'GHC.Core.SimpleOpt.simple_bind_pair' does not look through ticks when + looking at the RHS to decide whether it is a Type or Coercion, + - 'GHC.Core.Opt.Simplify.Iteration.completeBind' does not look through ticks + when looking at the RHS of an CoVar binding. + +This means it is vital to drop ticks around types/coercions: + + - (#26941) Core Lint rejects bindings of the form "let co = tick ..." + in which the LHS is a CoVar and the RHS is a ticked Coercion. + - (#27121) The simplifier mis-handles ticked coercion bindings, which can + result in 'lookupIdSubst' panics (due to failing to extend the substitution + with a coercion). +-} mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks @@ -2545,8 +2706,8 @@ exprIsTickedString = isJust . exprIsTickedString_maybe exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString exprIsTickedString_maybe (Lit (LitString bs)) = Just bs exprIsTickedString_maybe (Tick t e) - -- we don't tick literals with CostCentre ticks, compare to mkTick - | tickishPlace t == PlaceCostCentre = Nothing + -- Shortcut: ticks with code never wrap literals (compare with 'mkTick') + | tickishIsCode t = Nothing | otherwise = exprIsTickedString_maybe e exprIsTickedString_maybe _ = Nothing ===================================== compiler/GHC/Types/Tickish.hs ===================================== @@ -17,6 +17,7 @@ module GHC.Types.Tickish ( TickishPlacement(..), tickishPlace, tickishContains, + combineTickish_maybe, -- * Breakpoint tick identifiers BreakpointId(..), BreakTickIndex @@ -261,8 +262,12 @@ Ticks have two independent attributes: See Note [Scoped ticks] +Note that profiling notes which both count and scope can be split into two +separate ticks, one that counts and doesn't scope and one that scopes and doesn't +count; see 'tickishCanSplit', 'mkNoCount' and 'mkNoScope'. + Note [Counting ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~ The following ticks count: - ProfNote ticks with profNoteCounts = True - HPC ticks @@ -290,7 +295,7 @@ sharing, so in practice the actual number of ticks may vary, except that we never change the value from zero to non-zero or vice-versa. Note [Scoped ticks] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~ The following ticks are scoped: - ProfNote ticks with profNoteScope = True - Breakpoints @@ -375,6 +380,61 @@ Whether we are allowed to float in additional cost depends on the tick: While these transformations are legal, we want to make a best effort to only make use of them where it exposes transformation opportunities. + +Note [Tickish placement] +~~~~~~~~~~~~~~~~~~~~~~~~ +The placement behaviour of ticks (i.e. which nodes we want the tick to be placed +around in the AST) is governed by 'TickishPlacement'. +From most restrictive to least restrictive placement rules: + + - PlaceRuntime: counting ticks. + + Ticks with 'PlaceRuntime' placement want to be placed around run-time + expressions. They can be moved through pure compile-time constructs such as + other type arguments, casts, or type lambdas: + + tick <t> (f @ty) ==> (tick <t> f) @ty + tick <t> (e |> co) ==> (tick <t> e) |> co + tick <t> (/\a. e) ==> /\a. tick <t> e + + This is the most restrictive placement rule for ticks, as all tickishs have + in common that they want to track runtime behaviour. + + Any tick that counts (see Note [Counting ticks]) has 'PlaceRuntime' placement. + + - PlaceNonLam: source notes. + + Like PlaceRuntime, but we can also float the tick through value lambdas: + + tick <t> (\x. e) ==> \x. tick <t> e + + This makes sense where there is little difference between annotating the + lambda and annotating the lambda's code. + + - PlaceCostCentre: non-counting profiling ticks. + + In addition to floating through lambdas, cost-centre style tickishs can be + pushed into (saturated) constructor applications, and can be eliminated when + placed around non-function variables: + + tick <t> (C e1 e2) ==> C (tick <t> e1) (tick <t> e2) + + tick <t> (x :: Int) ==> (x :: Int) + + Neither the constructor application nor the variable 'x' are likely to have + any cost worth mentioning. + +We generally try to push ticks inwards until they end up placed around a Core +expression that is appropriate for their placement rule, as described above. +This gives us the opportunity to eliminate the tick, either by combining it with +another tick (see 'combineTickish_maybe') or by dropping it altogether. For +example, a (non-counting) SCC around a non-function variable can be dropped, as +there is no cost to scope over. + +After the tick has been placed by 'mkTick', the simplifier may later (during +simplification) decide to float it outwards (see e.g. GHC.Core.Opt.Simplify.Iteration.simplTick). +The story here is not fully worked out, as the simplifier calls 'mkTick', which +might push the tick inwards again. -} -- | Returns @True@ for ticks that can be floated upwards easily even @@ -441,35 +501,19 @@ isProfTick _ = False -- annotating for example using @mkTick@. If we find that we want to -- put a tickish on an expression ruled out here, we try to float it -- inwards until we find a suitable expression. +-- +-- See Note [Tickish placement]. data TickishPlacement = - -- | Place ticks exactly on run-time expressions. We can still - -- move the tick through pure compile-time constructs such as - -- other ticks, casts or type lambdas. This is the most - -- restrictive placement rule for ticks, as all tickishs have in - -- common that they want to track runtime processes. The only - -- legal placement rule for counting ticks. - -- NB: We generally try to move these as close to the relevant - -- runtime expression as possible. This means they get pushed through - -- tyoe arguments. E.g. we create `(tick f) @Bool` instead of `tick (f @Bool)`. + -- | Place ticks exactly on run-time expressions, moving them through pure + -- compile-time constructs such as other ticks, casts or type lambdas. PlaceRuntime - -- | As @PlaceRuntime@, but we float the tick through all - -- lambdas. This makes sense where there is little difference - -- between annotating the lambda and annotating the lambda's code. + -- | As @PlaceRuntime@, but also allow to float the tick through all lambdas. | PlaceNonLam - -- | In addition to floating through lambdas, cost-centre style - -- tickishs can also be moved from constructors, non-function - -- variables and literals. For example: - -- - -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... - -- - -- Neither the constructor application, the variable or the - -- literal are likely to have any cost worth mentioning. And even - -- if y names a thunk, the call would not care about the - -- evaluation context. Therefore removing all annotations in the - -- above example is safe. + -- | As 'PlaceNonLam', but also float through constructors, non-function + -- variables and literals. | PlaceCostCentre deriving (Eq,Show) @@ -477,7 +521,9 @@ data TickishPlacement = instance Outputable TickishPlacement where ppr = text . show --- | Placement behaviour we want for the ticks +-- | Placement behaviour we want for the ticks. +-- +-- See Note [Tickish placement]. tickishPlace :: GenTickish pass -> TickishPlacement tickishPlace n@ProfNote{} | profNoteCount n = PlaceRuntime @@ -486,6 +532,43 @@ tickishPlace HpcTick{} = PlaceRuntime tickishPlace Breakpoint{} = PlaceRuntime tickishPlace SourceNote{} = PlaceNonLam +-- | Merge two ticks into one, if that is possible. +-- +-- Examples: +-- +-- - combine two source note ticks if one contains the other, +-- - combine a non-counting profiling tick with a non-scoping profiling tick +-- for the same cost centre +-- - combine two equal breakpoint ticks or HPC ticks +combineTickish_maybe :: Eq (GenTickish pass) + => GenTickish pass -> GenTickish pass -> Maybe (GenTickish pass) +combineTickish_maybe + (ProfNote { profNoteCC = cc1, profNoteCount = cnt1, profNoteScope = scope1 }) + (ProfNote { profNoteCC = cc2, profNoteCount = cnt2, profNoteScope = scope2 }) + | cc1 == cc2 + , not cnt1 || not cnt2 + = Just $ ProfNote { profNoteCC = cc1 + , profNoteCount = cnt1 || cnt2 + , profNoteScope = scope1 || scope2 + } +combineTickish_maybe t1@(SourceNote sp1 n1) t2@(SourceNote sp2 n2) + | n1 == n2 + , sp1 `containsSpan` sp2 + = Just t1 + | n1 == n2 + , sp2 `containsSpan` sp1 + = Just t2 + -- NB: it would be possible to use 'combineRealSrcSpans' instead, + -- but that has the risk of combining many source note ticks into a single + -- tick with a huge source span. +combineTickish_maybe t1@(HpcTick {}) t2@(HpcTick {}) + | t1 == t2 + = Just t1 +combineTickish_maybe t1@(Breakpoint {}) t2@(Breakpoint {}) + | t1 == t2 + = Just t1 +combineTickish_maybe _ _ = Nothing + -- | Returns whether one tick "contains" the other one, therefore -- making the second tick redundant. tickishContains :: Eq (GenTickish pass) ===================================== libraries/ghc-heap/tests/tso_and_stack_closures.hs ===================================== @@ -48,7 +48,9 @@ main = do assertEqual (cc_module myCostCentre) "Main" assertEqual (cc_srcloc myCostCentre) (Just "tso_and_stack_closures.hs:24:48-80") assertEqual (cc_is_caf myCostCentre) False - Nothing -> error $ "MyCostCentre not found in:\n" ++ unlines (cc_label <$> linkedCostCentres costCentre) + Nothing -> error "MyCostCentre not found" + -- Don't print all of 'linkedCostCentres costCentre', + -- as that is ~20k lines of output. #endif linkedCostCentres :: Maybe CostCentre -> [CostCentre] ===================================== testsuite/tests/profiling/should_compile/T27121.hs ===================================== @@ -0,0 +1,12 @@ +module T27121 where + +import T27121_aux + +updateFileDiagnostics + :: LanguageContextEnv () + -> IO () +updateFileDiagnostics env = do + withTrace $ \ _tag -> + runLspT env $ do + sendNotification SMethod_TextDocumentPublishDiagnostics + PublishDiagnosticsParams ===================================== testsuite/tests/profiling/should_compile/T27121_aux.hs ===================================== @@ -0,0 +1,354 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module T27121_aux + ( withTrace + , sendNotification + , LspT, runLspT + , SMethod(..) + , LanguageContextEnv + , PublishDiagnosticsParams(..) + ) + where + +-- base +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Data.Kind ( Type ) +import GHC.TypeLits ( Symbol ) + +-------------------------------------------------------------------------------- + +withTrace :: Monad m => ((String -> String -> m ()) -> m a) -> m a +withTrace act + | myUserTracingEnabled + = return undefined + | otherwise = act (\_ _ -> pure ()) +{-# NOINLINE withTrace #-} + +myUserTracingEnabled :: Bool +myUserTracingEnabled = False +{-# NOINLINE myUserTracingEnabled #-} + +type Text = String + +newtype LspT config a = LspT {unLspT :: LanguageContextEnv config -> IO a} + +instance Functor (LspT config) where + fmap f (LspT g) = LspT (fmap f . g) + +instance Applicative (LspT config) where + pure = LspT . const . pure + LspT f <*> LspT a = LspT $ \ env -> f env <*> a env +instance Monad (LspT config) where + LspT a >>= f = LspT $ \ env -> do + b <- a env + unLspT ( f b ) env +instance MonadIO (LspT config) where + liftIO = LspT . const . liftIO + +type role LspT representational nominal + +runLspT :: LanguageContextEnv config -> LspT config a -> IO a +runLspT env (LspT f) = f env +{-# INLINE runLspT #-} + +data PublishDiagnosticsParams = PublishDiagnosticsParams + +data LanguageContextEnv config = + LanguageContextEnv + { resSendMessage :: FromServerMessage -> IO () } + + +sendNotification :: + forall (m :: Method ServerToClient Notification) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + f () +sendNotification m params = + let msg = TNotificationMessage { _method = m, _params = params } + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + +type Method :: MessageDirection -> MessageKind -> Type +data Method f t where + Method_TextDocumentImplementation :: Method ClientToServer Request + Method_TextDocumentTypeDefinition :: Method ClientToServer Request + Method_WorkspaceWorkspaceFolders :: Method ServerToClient Request + Method_WorkspaceConfiguration :: Method ServerToClient Request + Method_TextDocumentDocumentColor :: Method ClientToServer Request + Method_TextDocumentColorPresentation :: Method ClientToServer Request + Method_TextDocumentFoldingRange :: Method ClientToServer Request + Method_TextDocumentDeclaration :: Method ClientToServer Request + Method_TextDocumentSelectionRange :: Method ClientToServer Request + Method_WindowWorkDoneProgressCreate :: Method ServerToClient Request + Method_TextDocumentPrepareCallHierarchy :: Method ClientToServer Request + Method_CallHierarchyIncomingCalls :: Method ClientToServer Request + Method_CallHierarchyOutgoingCalls :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFull :: Method ClientToServer Request + Method_TextDocumentSemanticTokensFullDelta :: Method ClientToServer Request + Method_TextDocumentSemanticTokensRange :: Method ClientToServer Request + Method_WorkspaceSemanticTokensRefresh :: Method ServerToClient Request + Method_WindowShowDocument :: Method ServerToClient Request + Method_TextDocumentLinkedEditingRange :: Method ClientToServer Request + Method_WorkspaceWillCreateFiles :: Method ClientToServer Request + Method_WorkspaceWillRenameFiles :: Method ClientToServer Request + Method_WorkspaceWillDeleteFiles :: Method ClientToServer Request + Method_TextDocumentMoniker :: Method ClientToServer Request + Method_TextDocumentPrepareTypeHierarchy :: Method ClientToServer Request + Method_TypeHierarchySupertypes :: Method ClientToServer Request + Method_TypeHierarchySubtypes :: Method ClientToServer Request + Method_TextDocumentInlineValue :: Method ClientToServer Request + Method_WorkspaceInlineValueRefresh :: Method ServerToClient Request + Method_TextDocumentInlayHint :: Method ClientToServer Request + Method_InlayHintResolve :: Method ClientToServer Request + Method_WorkspaceInlayHintRefresh :: Method ServerToClient Request + Method_TextDocumentDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnostic :: Method ClientToServer Request + Method_WorkspaceDiagnosticRefresh :: Method ServerToClient Request + Method_ClientRegisterCapability :: Method ServerToClient Request + Method_ClientUnregisterCapability :: Method ServerToClient Request + Method_Initialize :: Method ClientToServer Request + Method_Shutdown :: Method ClientToServer Request + Method_WindowShowMessageRequest :: Method ServerToClient Request + Method_TextDocumentWillSaveWaitUntil :: Method ClientToServer Request + Method_TextDocumentCompletion :: Method ClientToServer Request + Method_CompletionItemResolve :: Method ClientToServer Request + Method_TextDocumentHover :: Method ClientToServer Request + Method_TextDocumentSignatureHelp :: Method ClientToServer Request + Method_TextDocumentDefinition :: Method ClientToServer Request + Method_TextDocumentReferences :: Method ClientToServer Request + Method_TextDocumentDocumentHighlight :: Method ClientToServer Request + Method_TextDocumentDocumentSymbol :: Method ClientToServer Request + Method_TextDocumentCodeAction :: Method ClientToServer Request + Method_CodeActionResolve :: Method ClientToServer Request + Method_WorkspaceSymbol :: Method ClientToServer Request + Method_WorkspaceSymbolResolve :: Method ClientToServer Request + Method_TextDocumentCodeLens :: Method ClientToServer Request + Method_CodeLensResolve :: Method ClientToServer Request + Method_WorkspaceCodeLensRefresh :: Method ServerToClient Request + Method_TextDocumentDocumentLink :: Method ClientToServer Request + Method_DocumentLinkResolve :: Method ClientToServer Request + Method_TextDocumentFormatting :: Method ClientToServer Request + Method_TextDocumentRangeFormatting :: Method ClientToServer Request + Method_TextDocumentOnTypeFormatting :: Method ClientToServer Request + Method_TextDocumentRename :: Method ClientToServer Request + Method_TextDocumentPrepareRename :: Method ClientToServer Request + Method_WorkspaceExecuteCommand :: Method ClientToServer Request + Method_WorkspaceApplyEdit :: Method ServerToClient Request + Method_WorkspaceDidChangeWorkspaceFolders :: Method ClientToServer Notification + Method_WindowWorkDoneProgressCancel :: Method ClientToServer Notification + Method_WorkspaceDidCreateFiles :: Method ClientToServer Notification + Method_WorkspaceDidRenameFiles :: Method ClientToServer Notification + Method_WorkspaceDidDeleteFiles :: Method ClientToServer Notification + Method_NotebookDocumentDidOpen :: Method ClientToServer Notification + Method_NotebookDocumentDidChange :: Method ClientToServer Notification + Method_NotebookDocumentDidSave :: Method ClientToServer Notification + Method_NotebookDocumentDidClose :: Method ClientToServer Notification + Method_Initialized :: Method ClientToServer Notification + Method_Exit :: Method ClientToServer Notification + Method_WorkspaceDidChangeConfiguration :: Method ClientToServer Notification + Method_WindowShowMessage :: Method ServerToClient Notification + Method_WindowLogMessage :: Method ServerToClient Notification + Method_TelemetryEvent :: Method ServerToClient Notification + Method_TextDocumentDidOpen :: Method ClientToServer Notification + Method_TextDocumentDidChange :: Method ClientToServer Notification + Method_TextDocumentDidClose :: Method ClientToServer Notification + Method_TextDocumentDidSave :: Method ClientToServer Notification + Method_TextDocumentWillSave :: Method ClientToServer Notification + Method_WorkspaceDidChangeWatchedFiles :: Method ClientToServer Notification + Method_TextDocumentPublishDiagnostics :: Method ServerToClient Notification + Method_SetTrace :: Method ClientToServer Notification + Method_LogTrace :: Method ServerToClient Notification + Method_CancelRequest :: Method f Notification + Method_Progress :: Method f Notification + Method_CustomMethod :: Symbol -> Method f t + +type SMethod :: forall f t . Method f t -> Type +data SMethod m where + SMethod_TextDocumentImplementation :: SMethod Method_TextDocumentImplementation + SMethod_TextDocumentTypeDefinition :: SMethod Method_TextDocumentTypeDefinition + SMethod_WorkspaceWorkspaceFolders :: SMethod Method_WorkspaceWorkspaceFolders + SMethod_WorkspaceConfiguration :: SMethod Method_WorkspaceConfiguration + SMethod_TextDocumentDocumentColor :: SMethod Method_TextDocumentDocumentColor + SMethod_TextDocumentColorPresentation :: SMethod Method_TextDocumentColorPresentation + SMethod_TextDocumentFoldingRange :: SMethod Method_TextDocumentFoldingRange + SMethod_TextDocumentDeclaration :: SMethod Method_TextDocumentDeclaration + SMethod_TextDocumentSelectionRange :: SMethod Method_TextDocumentSelectionRange + SMethod_WindowWorkDoneProgressCreate :: SMethod Method_WindowWorkDoneProgressCreate + SMethod_TextDocumentPrepareCallHierarchy :: SMethod Method_TextDocumentPrepareCallHierarchy + SMethod_CallHierarchyIncomingCalls :: SMethod Method_CallHierarchyIncomingCalls + SMethod_CallHierarchyOutgoingCalls :: SMethod Method_CallHierarchyOutgoingCalls + SMethod_TextDocumentSemanticTokensFull :: SMethod Method_TextDocumentSemanticTokensFull + SMethod_TextDocumentSemanticTokensFullDelta :: SMethod Method_TextDocumentSemanticTokensFullDelta + SMethod_TextDocumentSemanticTokensRange :: SMethod Method_TextDocumentSemanticTokensRange + SMethod_WorkspaceSemanticTokensRefresh :: SMethod Method_WorkspaceSemanticTokensRefresh + SMethod_WindowShowDocument :: SMethod Method_WindowShowDocument + SMethod_TextDocumentLinkedEditingRange :: SMethod Method_TextDocumentLinkedEditingRange + SMethod_WorkspaceWillCreateFiles :: SMethod Method_WorkspaceWillCreateFiles + SMethod_WorkspaceWillRenameFiles :: SMethod Method_WorkspaceWillRenameFiles + SMethod_WorkspaceWillDeleteFiles :: SMethod Method_WorkspaceWillDeleteFiles + SMethod_TextDocumentMoniker :: SMethod Method_TextDocumentMoniker + SMethod_TextDocumentPrepareTypeHierarchy :: SMethod Method_TextDocumentPrepareTypeHierarchy + SMethod_TypeHierarchySupertypes :: SMethod Method_TypeHierarchySupertypes + SMethod_TypeHierarchySubtypes :: SMethod Method_TypeHierarchySubtypes + SMethod_TextDocumentInlineValue :: SMethod Method_TextDocumentInlineValue + SMethod_WorkspaceInlineValueRefresh :: SMethod Method_WorkspaceInlineValueRefresh + SMethod_TextDocumentInlayHint :: SMethod Method_TextDocumentInlayHint + SMethod_InlayHintResolve :: SMethod Method_InlayHintResolve + SMethod_WorkspaceInlayHintRefresh :: SMethod Method_WorkspaceInlayHintRefresh + SMethod_TextDocumentDiagnostic :: SMethod Method_TextDocumentDiagnostic + SMethod_WorkspaceDiagnostic :: SMethod Method_WorkspaceDiagnostic + SMethod_WorkspaceDiagnosticRefresh :: SMethod Method_WorkspaceDiagnosticRefresh + SMethod_ClientRegisterCapability :: SMethod Method_ClientRegisterCapability + SMethod_ClientUnregisterCapability :: SMethod Method_ClientUnregisterCapability + SMethod_Initialize :: SMethod Method_Initialize + SMethod_Shutdown :: SMethod Method_Shutdown + SMethod_WindowShowMessageRequest :: SMethod Method_WindowShowMessageRequest + SMethod_TextDocumentWillSaveWaitUntil :: SMethod Method_TextDocumentWillSaveWaitUntil + SMethod_TextDocumentCompletion :: SMethod Method_TextDocumentCompletion + SMethod_CompletionItemResolve :: SMethod Method_CompletionItemResolve + SMethod_TextDocumentHover :: SMethod Method_TextDocumentHover + SMethod_TextDocumentSignatureHelp :: SMethod Method_TextDocumentSignatureHelp + SMethod_TextDocumentDefinition :: SMethod Method_TextDocumentDefinition + SMethod_TextDocumentReferences :: SMethod Method_TextDocumentReferences + SMethod_TextDocumentDocumentHighlight :: SMethod Method_TextDocumentDocumentHighlight + SMethod_TextDocumentDocumentSymbol :: SMethod Method_TextDocumentDocumentSymbol + SMethod_TextDocumentCodeAction :: SMethod Method_TextDocumentCodeAction + SMethod_CodeActionResolve :: SMethod Method_CodeActionResolve + SMethod_WorkspaceSymbol :: SMethod Method_WorkspaceSymbol + SMethod_WorkspaceSymbolResolve :: SMethod Method_WorkspaceSymbolResolve + SMethod_TextDocumentCodeLens :: SMethod Method_TextDocumentCodeLens + SMethod_CodeLensResolve :: SMethod Method_CodeLensResolve + SMethod_WorkspaceCodeLensRefresh :: SMethod Method_WorkspaceCodeLensRefresh + SMethod_TextDocumentDocumentLink :: SMethod Method_TextDocumentDocumentLink + SMethod_DocumentLinkResolve :: SMethod Method_DocumentLinkResolve + SMethod_TextDocumentFormatting :: SMethod Method_TextDocumentFormatting + SMethod_TextDocumentRangeFormatting :: SMethod Method_TextDocumentRangeFormatting + SMethod_TextDocumentOnTypeFormatting :: SMethod Method_TextDocumentOnTypeFormatting + SMethod_TextDocumentRename :: SMethod Method_TextDocumentRename + SMethod_TextDocumentPrepareRename :: SMethod Method_TextDocumentPrepareRename + SMethod_WorkspaceExecuteCommand :: SMethod Method_WorkspaceExecuteCommand + SMethod_WorkspaceApplyEdit :: SMethod Method_WorkspaceApplyEdit + SMethod_WorkspaceDidChangeWorkspaceFolders :: SMethod Method_WorkspaceDidChangeWorkspaceFolders + SMethod_WindowWorkDoneProgressCancel :: SMethod Method_WindowWorkDoneProgressCancel + SMethod_WorkspaceDidCreateFiles :: SMethod Method_WorkspaceDidCreateFiles + SMethod_WorkspaceDidRenameFiles :: SMethod Method_WorkspaceDidRenameFiles + SMethod_WorkspaceDidDeleteFiles :: SMethod Method_WorkspaceDidDeleteFiles + SMethod_NotebookDocumentDidOpen :: SMethod Method_NotebookDocumentDidOpen + SMethod_NotebookDocumentDidChange :: SMethod Method_NotebookDocumentDidChange + SMethod_NotebookDocumentDidSave :: SMethod Method_NotebookDocumentDidSave + SMethod_NotebookDocumentDidClose :: SMethod Method_NotebookDocumentDidClose + SMethod_Initialized :: SMethod Method_Initialized + SMethod_Exit :: SMethod Method_Exit + SMethod_WorkspaceDidChangeConfiguration :: SMethod Method_WorkspaceDidChangeConfiguration + SMethod_WindowShowMessage :: SMethod Method_WindowShowMessage + SMethod_WindowLogMessage :: SMethod Method_WindowLogMessage + SMethod_TelemetryEvent :: SMethod Method_TelemetryEvent + SMethod_TextDocumentDidOpen :: SMethod Method_TextDocumentDidOpen + SMethod_TextDocumentDidChange :: SMethod Method_TextDocumentDidChange + SMethod_TextDocumentDidClose :: SMethod Method_TextDocumentDidClose + SMethod_TextDocumentDidSave :: SMethod Method_TextDocumentDidSave + SMethod_TextDocumentWillSave :: SMethod Method_TextDocumentWillSave + SMethod_WorkspaceDidChangeWatchedFiles :: SMethod Method_WorkspaceDidChangeWatchedFiles + SMethod_TextDocumentPublishDiagnostics :: SMethod Method_TextDocumentPublishDiagnostics + SMethod_SetTrace :: SMethod Method_SetTrace + SMethod_LogTrace :: SMethod Method_LogTrace + SMethod_CancelRequest :: SMethod Method_CancelRequest + SMethod_Progress :: SMethod Method_Progress + +type SServerMethod (m :: Method ServerToClient t) = SMethod m + +data MessageDirection = ServerToClient | ClientToServer + +data MessageKind = Notification | Request + + +type ServerNotOrReq :: forall t. Method ServerToClient t -> Type +data ServerNotOrReq m where + IsServerNot :: + ( TMessage m ~ TNotificationMessage m + ) => + ServerNotOrReq (m :: Method ServerToClient Notification) + IsServerReq :: + forall (m :: Method ServerToClient Request). + ( TMessage m ~ TRequestMessage m + ) => + ServerNotOrReq m + +type TMessage :: forall f t. Method f t -> Type +type family TMessage m where + TMessage (Method_CustomMethod s :: Method f t) = () + TMessage (m :: Method f Request) = TRequestMessage m + TMessage (m :: Method f Notification) = TNotificationMessage m + + +data TNotificationMessage (m :: Method f Notification) = TNotificationMessage + { _method :: SMethod m + , _params :: MessageParams m + } + +data TRequestMessage (m :: Method f Request) = TRequestMessage + +type MessageParams :: forall f t . Method f t -> Type +type family MessageParams (m :: Method f t) where + MessageParams Method_TextDocumentPublishDiagnostics = PublishDiagnosticsParams + +class MonadIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadLsp config (LspT config) where + {-# INLINE getLspEnv #-} + getLspEnv = LspT pure + + +{-# INLINE splitServerMethod #-} +splitServerMethod :: SServerMethod m -> ServerNotOrReq m +splitServerMethod = \case + SMethod_TextDocumentPublishDiagnostics -> IsServerNot + SMethod_WindowShowMessage -> IsServerNot + SMethod_WindowShowMessageRequest -> IsServerReq + SMethod_WindowShowDocument -> IsServerReq + SMethod_WindowLogMessage -> IsServerNot + SMethod_WindowWorkDoneProgressCreate -> IsServerReq + SMethod_Progress -> IsServerNot + SMethod_TelemetryEvent -> IsServerNot + SMethod_ClientRegisterCapability -> IsServerReq + SMethod_ClientUnregisterCapability -> IsServerReq + SMethod_WorkspaceWorkspaceFolders -> IsServerReq + SMethod_WorkspaceConfiguration -> IsServerReq + SMethod_WorkspaceApplyEdit -> IsServerReq + SMethod_LogTrace -> IsServerNot + SMethod_CancelRequest -> IsServerNot + SMethod_WorkspaceCodeLensRefresh -> IsServerReq + SMethod_WorkspaceSemanticTokensRefresh -> IsServerReq + SMethod_WorkspaceInlineValueRefresh -> IsServerReq + SMethod_WorkspaceInlayHintRefresh -> IsServerReq + SMethod_WorkspaceDiagnosticRefresh -> IsServerReq + +fromServerNot :: + forall (m :: Method ServerToClient Notification). + TMessage m ~ TNotificationMessage m => + TNotificationMessage m -> + FromServerMessage +fromServerNot m@TNotificationMessage{_method = meth} = FromServerMess meth m + + +data FromServerMessage' a where + FromServerMess :: forall t (m :: Method ServerToClient t) a. SMethod m -> TMessage m -> FromServerMessage' a + FromServerRsp :: forall (m :: Method ClientToServer Request) a. a m -> TResponseMessage m -> FromServerMessage' a + +type FromServerMessage = FromServerMessage' SMethod + +data TResponseMessage (m :: Method f Request) = TResponseMessage + +sendToClient :: MonadLsp config m => FromServerMessage -> m () +sendToClient msg = do + f <- resSendMessage <$> getLspEnv + liftIO $ f msg +{-# INLINE sendToClient #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -21,3 +21,4 @@ test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) test('T26056', [test_opts], compile, ['-O -prof']) +test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-O -prof -fprof-auto']) ===================================== testsuite/tests/simplCore/should_compile/T26941.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +module T26941 where + +import GHC.TypeLits + +import T26941_aux ( SMayNat(SKnown), ListH, shxHead ) + +shsHead :: ListH (Just n : sh) Int -> SNat n +shsHead shx = + case shxHead shx of + SKnown SNat -> SNat ===================================== testsuite/tests/simplCore/should_compile/T26941_aux.hs ===================================== @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T26941_aux where + +import Data.Kind +import GHC.TypeLits + +shxHead :: ListH (n : sh) i -> SMayNat i n +shxHead list = {-# SCC "bad_scc" #-} + ( case list of (i `ConsKnown` _) -> SKnown i ) + +type ListH :: [Maybe Nat] -> Type -> Type +data ListH sh i where + ConsKnown :: SNat n -> ListH sh i -> ListH (Just n : sh) i + +data SMayNat i n where + SKnown :: SNat n -> SMayNat i (Just n) ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -576,6 +576,8 @@ test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniqu test('T26349', normal, compile, ['-O -ddump-rules']) test('T26681', normal, compile, ['-O']) +test('T26941', [extra_files(['T26941_aux.hs']), req_profiling], multimod_compile, ['T26941', '-v0 -O -prof']) + # T26709: we expect three `case` expressions not four test('T26709', [grep_errmsg(r'case')], multimod_compile, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a32431b39f2f790975abc1d444625… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e0a32431b39f2f790975abc1d444625… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-reinstallable-base] More....[skip ci]
by Simon Peyton Jones (＠simonpj) 02 Apr '26

02 Apr '26

Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 809c39ee by Simon Peyton Jones at 2026-04-02T17:37:00+01:00 More....[skip ci] Lots of Names have moved to new mechanism BuiltinRules had KnownKeyNameKeys Start on updating RdrName but incomplete, hence skip ci - - - - - 30 changed files: - compiler/GHC/Builtin/Names.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Opt/ConstantFold.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Match/Literal.hs - compiler/GHC/Tc/Deriv/Generate.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/Unique/FM.hs - libraries/base/src/Data/Functor/Classes.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs - libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot - libraries/ghc-internal/src/GHC/Internal/CString.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs - libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs - libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs - libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs - libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs - libraries/ghc-internal/src/GHC/Internal/Magic.hs - libraries/ghc-internal/src/GHC/Internal/Read.hs - libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs Changes: ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -222,7 +222,7 @@ basicKnownKeyTable , (mkTcOcc "Eq", eqClassKey) , (mkVarOcc "==", eqClassOpKey) - -- Class Num + -- Numeric operations , (mkTcOcc "Num", numClassKey) , (mkVarOcc "-", minusClassOpKey) , (mkVarOcc "negate", negateClassOpKey) @@ -230,6 +230,8 @@ basicKnownKeyTable , (mkVarOcc "fromRational", fromRationalClassOpKey) , (mkVarOcc "mkRationalBase2", mkRationalBase2IdKey) , (mkVarOcc "mkRationalBase10", mkRationalBase10IdKey) + , (mkVarOcc "divInt#", divIntIdKey) + , (mkVarOcc "modInt#", modIntIdKey) -- Class Functor , (mkTcOcc "Functor", functorClassKey) @@ -286,6 +288,79 @@ basicKnownKeyTable , (mkVarOcc "bindIO", bindIOIdKey) , (mkVarOcc "returnIO", returnIOIdKey) , (mkVarOcc "print", printIdKey) + + -- Known-key names that have BuiltinRules in ConstantFold + , (mkVarOcc "unpackFoldrCString#", unpackCStringFoldrIdKey) + , (mkVarOcc "unpackFoldrCStringUtf8#", unpackCStringFoldrUtf8IdKey) + , (mkVarOcc "unpackAppendCString#", unpackCStringAppendIdKey) + , (mkVarOcc "unpackAppendCStringUtf8#", unpackCStringAppendUtf8IdKey) + , (mkVarOcc "cstringLength#", cstringLengthIdKey) + + , (mkVarOcc "eqString", eqStringIdKey) + , (mkVarOcc "inline", inlineIdKey) + + , (mkVarOcc "unsafeEqualityProof", unsafeEqualityProofIdKey) + , (mkTcOcc "UnsafeEquality", unsafeEqualityTyConKey) + , (mkDataOcc "UnsafeRefl", unsafeReflDataConKey) + + -- Bignum operations, have BuiltinRules in ConstantFold + , (mkVarOcc "bigNatEq#", bignatEqIdKey) + , (mkVarOcc "bigNatCompare", bignatCompareIdKey) + , (mkVarOcc "bigNatCompareWord#", bignatCompareWordIdKey) + , (mkVarOcc "naturalToWord#", naturalToWordIdKey) + , (mkVarOcc "naturalPopCount#", naturalPopCountIdKey) + , (mkVarOcc "naturalShiftR#", naturalShiftRIdKey) + , (mkVarOcc "naturalShiftL#", naturalShiftLIdKey) + , (mkVarOcc "naturalAdd", naturalAddIdKey) + , (mkVarOcc "naturalSub", naturalSubIdKey) + , (mkVarOcc "naturalSubThrow", naturalSubThrowIdKey) + , (mkVarOcc "naturalSubUnsafe", naturalSubUnsafeIdKey) + , (mkVarOcc "naturalMul", naturalMulIdKey) + , (mkVarOcc "naturalQuotRem#", naturalQuotRemIdKey) + , (mkVarOcc "naturalQuot", naturalQuotIdKey) + , (mkVarOcc "naturalRem", naturalRemIdKey) + , (mkVarOcc "naturalAnd", naturalAndIdKey) + , (mkVarOcc "naturalOr", naturalOrIdKey) + , (mkVarOcc "naturalXor", naturalXorIdKey) + , (mkVarOcc "naturalTestBit#", naturalTestBitIdKey) + , (mkVarOcc "naturalBit#", naturalBitIdKey) + , (mkVarOcc "naturalGcd", naturalGcdIdKey) + , (mkVarOcc "naturalLcm", naturalLcmIdKey) + , (mkVarOcc "integerFromNatural", integerFromNaturalIdKey) + , (mkVarOcc "integerToNaturalClamp", integerToNaturalClampIdKey) + , (mkVarOcc "integerToNaturalThrow", integerToNaturalThrowIdKey) + , (mkVarOcc "integerToNatural", integerToNaturalIdKey) + , (mkVarOcc "integerToWord#", integerToWordIdKey) + , (mkVarOcc "integerToInt#", integerToIntIdKey) + , (mkVarOcc "integerToWord64#", integerToWord64IdKey) + , (mkVarOcc "integerToInt64#", integerToInt64IdKey) + , (mkVarOcc "integerFromWord#", integerFromWordIdKey) + , (mkVarOcc "integerFromWord64#", integerFromWord64IdKey) + , (mkVarOcc "integerFromInt64#", integerFromInt64IdKey) + , (mkVarOcc "integerAdd", integerAddIdKey) + , (mkVarOcc "integerMul", integerMulIdKey) + , (mkVarOcc "integerSub", integerSubIdKey) + , (mkVarOcc "integerNegate", integerNegateIdKey) + , (mkVarOcc "integerAbs", integerAbsIdKey) + , (mkVarOcc "integerPopCount#", integerPopCountIdKey) + , (mkVarOcc "integerQuot", integerQuotIdKey) + , (mkVarOcc "integerRem", integerRemIdKey) + , (mkVarOcc "integerDiv", integerDivIdKey) + , (mkVarOcc "integerMod", integerModIdKey) + , (mkVarOcc "integerDivMod#", integerDivModIdKey) + , (mkVarOcc "integerQuotRem#", integerQuotRemIdKey) + , (mkVarOcc "integerEncodeFloat#", integerEncodeFloatIdKey) + , (mkVarOcc "integerEncodeDouble#", integerEncodeDoubleIdKey) + , (mkVarOcc "integerGcd", integerGcdIdKey) + , (mkVarOcc "integerLcm", integerLcmIdKey) + , (mkVarOcc "integerAnd", integerAndIdKey) + , (mkVarOcc "integerOr", integerOrIdKey) + , (mkVarOcc "integerXor", integerXorIdKey) + , (mkVarOcc "integerComplement", integerComplementIdKey) + , (mkVarOcc "integerBit#", integerBitIdKey) + , (mkVarOcc "integerTestBit#", integerTestBitIdKey) + , (mkVarOcc "integerShiftL#", integerShiftLIdKey) + , (mkVarOcc "integerShiftR#", integerShiftRIdKey) ] basicKnownKeyNames :: [Name] -- See Note [Known-key names] @@ -353,9 +428,6 @@ basicKnownKeyNames toIntegerName, toRationalName, fromIntegralName, realToFracName, - -- Int# stuff - divIntName, modIntName, - -- String stuff fromStringName, @@ -370,9 +442,6 @@ basicKnownKeyNames bindMName, thenMName, returnMName, - -- Ix stuff - ixClassName, - -- Read stuff readClassName, @@ -384,9 +453,6 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - unpackCStringFoldrName, unpackCStringFoldrUtf8Name, - cstringLengthName, -- Non-empty lists nonEmptyTyConName, @@ -401,71 +467,12 @@ basicKnownKeyNames jsvalTyConName, -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, + otherwiseIdName, + assertName, assertErrorName, traceName, printName, dollarName, - -- ghc-bignum - integerFromNaturalName, - integerToNaturalClampName, - integerToNaturalThrowName, - integerToNaturalName, - integerToWordName, - integerToIntName, - integerToWord64Name, - integerToInt64Name, - integerFromWordName, - integerFromWord64Name, - integerFromInt64Name, - integerAddName, - integerMulName, - integerSubName, - integerNegateName, - integerAbsName, - integerPopCountName, - integerQuotName, - integerRemName, - integerDivName, - integerModName, - integerDivModName, - integerQuotRemName, - integerEncodeFloatName, - integerEncodeDoubleName, - integerGcdName, - integerLcmName, - integerAndName, - integerOrName, - integerXorName, - integerComplementName, - integerBitName, - integerTestBitName, - integerShiftLName, - integerShiftRName, - - naturalToWordName, - naturalPopCountName, - naturalShiftRName, - naturalShiftLName, - naturalAddName, - naturalSubName, - naturalSubThrowName, - naturalSubUnsafeName, - naturalMulName, - naturalQuotRemName, - naturalQuotName, - naturalRemName, - naturalAndName, - naturalOrName, - naturalXorName, - naturalTestBitName, - naturalBitName, - naturalGcdName, - naturalLcmName, - - bignatEqName, - -- Float/Double integerToFloatName, integerToDoubleName, @@ -535,9 +542,6 @@ basicKnownKeyNames , unsatisfiableIdName -- Unsafe coercion proofs - , unsafeEqualityProofName - , unsafeEqualityTyConName - , unsafeReflDataConName , unsafeCoercePrimName , unsafeUnpackJSStringUtf8ShShName @@ -1020,31 +1024,10 @@ metaDataDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData") metaData metaConsDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons") metaConsDataConKey metaSelDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel") metaSelDataConKey --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - -- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - eqStringName, cstringLengthName :: Name -cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey -eqStringName = varQual gHC_INTERNAL_BASE (fsLit "eqString") eqStringIdKey - +unpackCStringName, unpackCStringUtf8Name :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey - unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey -unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey - - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, geName, functorClassName :: Name @@ -1108,134 +1091,11 @@ fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromSt negateName :: Name negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey ---------------------------------- --- ghc-bignum ---------------------------------- -integerFromNaturalName - , integerToNaturalClampName - , integerToNaturalThrowName - , integerToNaturalName - , integerToWordName - , integerToIntName - , integerToWord64Name - , integerToInt64Name - , integerFromWordName - , integerFromWord64Name - , integerFromInt64Name - , integerAddName - , integerMulName - , integerSubName - , integerNegateName - , integerAbsName - , integerPopCountName - , integerQuotName - , integerRemName - , integerDivName - , integerModName - , integerDivModName - , integerQuotRemName - , integerEncodeFloatName - , integerEncodeDoubleName - , integerGcdName - , integerLcmName - , integerAndName - , integerOrName - , integerXorName - , integerComplementName - , integerBitName - , integerTestBitName - , integerShiftLName - , integerShiftRName - , naturalToWordName - , naturalPopCountName - , naturalShiftRName - , naturalShiftLName - , naturalAddName - , naturalSubName - , naturalSubThrowName - , naturalSubUnsafeName - , naturalMulName - , naturalQuotRemName - , naturalQuotName - , naturalRemName - , naturalAndName - , naturalOrName - , naturalXorName - , naturalTestBitName - , naturalBitName - , naturalGcdName - , naturalLcmName - , bignatEqName - , bignatCompareName - , bignatCompareWordName - :: Name - bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key --- Types and DataCons -bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey -bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey -bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey - -naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey -naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey -naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey -naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey -naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey -naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey -naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey -naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey -naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey -naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey -naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey -naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey -naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey -naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey -naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey -naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey -naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey -naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey -naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey - -integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey -integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey -integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey -integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey -integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey -integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey -integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey -integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey -integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey -integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey -integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey -integerAddName = bniVarQual "integerAdd" integerAddIdKey -integerMulName = bniVarQual "integerMul" integerMulIdKey -integerSubName = bniVarQual "integerSub" integerSubIdKey -integerNegateName = bniVarQual "integerNegate" integerNegateIdKey -integerAbsName = bniVarQual "integerAbs" integerAbsIdKey -integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey -integerQuotName = bniVarQual "integerQuot" integerQuotIdKey -integerRemName = bniVarQual "integerRem" integerRemIdKey -integerDivName = bniVarQual "integerDiv" integerDivIdKey -integerModName = bniVarQual "integerMod" integerModIdKey -integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey -integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey -integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey -integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey -integerGcdName = bniVarQual "integerGcd" integerGcdIdKey -integerLcmName = bniVarQual "integerLcm" integerLcmIdKey -integerAndName = bniVarQual "integerAnd" integerAndIdKey -integerOrName = bniVarQual "integerOr" integerOrIdKey -integerXorName = bniVarQual "integerXor" integerXorIdKey -integerComplementName = bniVarQual "integerComplement" integerComplementIdKey -integerBitName = bniVarQual "integerBit#" integerBitIdKey -integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey -integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey -integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey - --------------------------------- @@ -1262,10 +1122,6 @@ integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") int rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat#") rationalToFloatIdKey rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble#") rationalToDoubleIdKey --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey - -- Typeable representation types trModuleTyConName , trModuleDataConName @@ -1384,11 +1240,7 @@ unsatisfiableIdName = varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey -- Unsafe coercion proofs -unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, - unsafeReflDataConName :: Name -unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey -unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey -unsafeReflDataConName = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName:: Name unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey -- Dynamic ===================================== compiler/GHC/Core.hs ===================================== @@ -88,7 +88,7 @@ module GHC.Core ( RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, -- ** Operations on 'CoreRule's - ruleArity, ruleName, ruleIdName, ruleActivation, + ruleArity, ruleName, ruleKey, ruleActivation, setRuleIdName, ruleModule, isBuiltinRule, isLocalRule, isAutoRule, ) where @@ -96,19 +96,21 @@ module GHC.Core ( import GHC.Prelude import GHC.Platform -import GHC.Types.Var.Env( InScopeSet ) -import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Rules.Config ( RuleOpts ) +import GHC.Core.DataCon +import GHC.Unit.Module + import GHC.Types.InlinePragma import GHC.Types.Name import GHC.Types.Name.Set +import GHC.Types.Var.Env( InScopeSet ) +import GHC.Types.Var import GHC.Types.Literal import GHC.Types.Tickish -import GHC.Core.DataCon -import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Binary @@ -1508,14 +1510,17 @@ data CoreRule -- A built-in rule is always visible (there is no such thing as -- an orphan built-in rule.) | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above + ru_name :: RuleName, -- ^ As above + ru_key :: KnownKeyNameKey, -- ^ Identifies the function + -- Not its Name because BuiltInRules are constants + -- and GHC doesn't know the defining module + -- See Note [Overview of known-key names] ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments ru_try :: RuleFun -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' - -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + -- is just the rewrite of function applied to the first 'ru_nargs' args } -- See Note [Extra args in the target] in GHC.Core.Rules @@ -1538,7 +1543,7 @@ isAutoRule :: CoreRule -> Bool isAutoRule (BuiltinRule {}) = False isAutoRule (Rule { ru_auto = is_auto }) = is_auto --- | The number of arguments the 'ru_fn' must be applied +-- | The number of arguments the function must be applied -- to before the rule can match on it ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n @@ -1555,17 +1560,21 @@ ruleActivation :: CoreRule -> ActivationGhc ruleActivation (BuiltinRule { }) = AlwaysActive ruleActivation (Rule { ru_act = act }) = act --- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side -ruleIdName :: CoreRule -> Name -ruleIdName = ru_fn - isLocalRule :: CoreRule -> Bool isLocalRule (BuiltinRule {}) = False isLocalRule (Rule { ru_local = is_local }) = is_local +-- | The 'Unique' of the function at the head of the rule left hand side +ruleKey :: CoreRule -> Unique +ruleKey (Rule { ru_fn = name }) = nameUnique name +ruleKey (BuiltinRule { ru_key = key }) = key + -- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule -setRuleIdName nm ru = ru { ru_fn = nm } +setRuleIdName nm rule + = case rule of + Rule {} -> rule { ru_fn = nm } + BuiltinRule {} -> rule { ru_key = nameUnique nm } {- ************************************************************************ ===================================== compiler/GHC/Core/DataCon.hs ===================================== @@ -1810,7 +1810,7 @@ dataConCannotMatch :: [Type] -> DataCon -> Bool dataConCannotMatch tys con -- See (U6) in Note [Implementing unsafeCoerce] -- in base:Unsafe.Coerce - | dataConName con == unsafeReflDataConName + | con `hasKnownKey` unsafeReflDataConKey = False | null inst_theta = False -- Common | all isTyVarTy tys = False -- Also common ===================================== compiler/GHC/Core/Opt/ConstantFold.hs ===================================== @@ -37,7 +37,7 @@ import GHC.Types.Literal import GHC.Types.Literal.Floating import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Tickish -import GHC.Types.Name ( Name, nameOccName ) +import GHC.Types.Name ( Name, KnownKeyNameKey, nameUnique, nameOccName ) import GHC.Types.Basic import GHC.Core @@ -870,7 +870,10 @@ primOpRules nm = \case -- useful shorthands mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule -mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) +mkPrimOpRule nm arity rules + = Just $ mkBasicRule (occNameFS (nameOccName nm)) + (nameUnique nm) + arity (msum rules) mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) -> [RuleM CoreExpr] -> Maybe CoreRule @@ -1679,13 +1682,13 @@ but that is only a historical accident. ************************************************************************ -} -mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +mkBasicRule :: RuleName -> KnownKeyNameKey -> Int -> RuleM CoreExpr -> CoreRule -- Gives the Rule the same name as the primop itself -mkBasicRule op_name n_args rm - = BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, - ru_try = runRuleM rm } +mkBasicRule rule_nm op_key n_args rm + = BuiltinRule { ru_name = rule_nm + , ru_key = op_key + , ru_nargs = n_args + , ru_try = runRuleM rm } newtype RuleM r = RuleM { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r } @@ -2060,6 +2063,30 @@ dataToTagRule = a `mplus` b return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) +{- ********************************************************************* +* * + div and mod +* * +********************************************************************* -} + +divIntRule :: RuleM CoreExpr +divIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just n <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntSraOp) + `App` arg `App` mkIntVal platform n } ] + +modIntRule :: RuleM CoreExpr +modIntRule = msum [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero + , do { [arg, Lit (LitNumber LitNumInt d)] <- getArgs + ; Just _ <- return $ exactLog2 d + ; platform <- getPlatform + ; return $ Var (primOpId IntAndOp) + `App` arg `App` mkIntVal platform (d-1) } ] + {- ********************************************************************* * * unsafeEqualityProof @@ -2132,55 +2159,47 @@ is fine. builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [BuiltinRule { ru_name = fsLit "CStringFoldrLit", - ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_C }, - BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8", - ru_fn = unpackCStringFoldrUtf8Name, - ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 }, - BuiltinRule { ru_name = fsLit "CStringAppendLit", - ru_fn = unpackCStringAppendName, - ru_nargs = 2, ru_try = match_cstring_append_lit_C }, - BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8", - ru_fn = unpackCStringAppendUtf8Name, - ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 }, - BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, - BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName, - ru_nargs = 1, ru_try = match_cstring_length }, - BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, - - mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule, - - mkBasicRule divIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 div) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just n <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n - ], - - mkBasicRule modIntName 2 $ msum - [ nonZeroLit 1 >> binaryLit (intOp2 mod) - , leftZero - , do - [arg, Lit (LitNumber LitNumInt d)] <- getArgs - Just _ <- return $ exactLog2 d - platform <- getPlatform - return $ Var (primOpId IntAndOp) - `App` arg `App` mkIntVal platform (d - 1) - ] - ] + = [ BuiltinRule { ru_name = fsLit "CStringFoldrLit" + , ru_key = unpackCStringFoldrIdKey + , ru_nargs = 4, ru_try = match_cstring_foldr_lit_C } + , BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8" + , ru_key = unpackCStringFoldrUtf8IdKey + ,ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringAppendLit" + , ru_key = unpackCStringAppendIdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_C } + , BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8" + , ru_key = unpackCStringAppendUtf8IdKey + , ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 } + , BuiltinRule { ru_name = fsLit "CStringLength" + , ru_key = cstringLengthIdKey + , ru_nargs = 1, ru_try = match_cstring_length } + + , BuiltinRule { ru_name = fsLit "EqString" + , ru_key = eqStringIdKey + , ru_nargs = 2, ru_try = match_eq_string } + + , BuiltinRule { ru_name = fsLit "Inline" + , ru_key = inlineIdKey + , ru_nargs = 2, ru_try = \_ _ _ -> match_inline } + + , BuiltinRule { ru_name = fsLit "unsafeEqualityProof" + , ru_key = unsafeEqualityProofIdKey + , ru_nargs = 3, ru_try = runRuleM unsafeEqualityProofRule } + + , BuiltinRule { ru_name = fsLit "divInt#" + , ru_key = divIntIdKey + , ru_nargs = 2, ru_try = runRuleM divIntRule } + , BuiltinRule { ru_name = fsLit "modInt#" + , ru_key = modIntIdKey + , ru_nargs = 2, ru_try = runRuleM modIntRule } + ] ++ builtinBignumRules {-# NOINLINE builtinRules #-} --- there is no benefit to inlining these yet, despite this, GHC produces +-- There is no benefit to inlining these yet, despite this, GHC produces -- unfoldings for this regardless since the floated list entries look small. - {- Note [Built-in bignum rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have some built-in rules for operations on bignum types (Integer, Natural, @@ -2219,54 +2238,54 @@ RuleOpts. builtinBignumRules :: [CoreRule] builtinBignumRules = [ -- conversions - lit_to_integer "Word# -> Integer" integerFromWordName - , lit_to_integer "Int64# -> Integer" integerFromInt64Name - , lit_to_integer "Word64# -> Integer" integerFromWord64Name - , lit_to_integer "Natural -> Integer" integerFromNaturalName + lit_to_integer "Word# -> Integer" integerFromWordIdKey + , lit_to_integer "Int64# -> Integer" integerFromInt64IdKey + , lit_to_integer "Word64# -> Integer" integerFromWord64IdKey + , lit_to_integer "Natural -> Integer" integerFromNaturalIdKey - , integer_to_lit "Integer -> Word# (wrap)" integerToWordName mkWordLitWrap - , integer_to_lit "Integer -> Int# (wrap)" integerToIntName mkIntLitWrap - , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger) - , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64Name (\_ -> mkInt64LitInt64 . fromInteger) - , integer_to_lit "Integer -> Float#" integerToFloatName (\_ -> mkFloatLit . fromInteger) - , integer_to_lit "Integer -> Double#" integerToDoubleName (\_ -> mkDoubleLit . fromInteger) + , integer_to_lit "Integer -> Word# (wrap)" integerToWordIdKey mkWordLitWrap + , integer_to_lit "Integer -> Int# (wrap)" integerToIntIdKey mkIntLitWrap + , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64IdKey (\_ -> mkWord64LitWord64 . fromInteger) + , integer_to_lit "Integer -> Int64# (wrap)" integerToInt64IdKey (\_ -> mkInt64LitInt64 . fromInteger) + , integer_to_lit "Integer -> Float#" integerToFloatIdKey (\_ -> mkFloatLit . fromInteger) + , integer_to_lit "Integer -> Double#" integerToDoubleIdKey (\_ -> mkDoubleLit . fromInteger) - , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True - , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalName False False - , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False + , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampIdKey False True + , integer_to_natural "Integer -> Natural (wrap)" integerToNaturalIdKey False False + , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowIdKey True False - , natural_to_word "Natural -> Word# (wrap)" naturalToWordName + , natural_to_word "Natural -> Word# (wrap)" naturalToWordIdKey -- comparisons (return an unlifted Int#) - , bignum_bin_pred "bigNatEq#" bignatEqName (==) + , bignum_bin_pred "bigNatEq#" bignatEqIdKey (==) -- comparisons (return an Ordering) - , bignum_compare "bignatCompare" bignatCompareName - , bignum_compare "bignatCompareWord#" bignatCompareWordName + , bignum_compare "bignatCompare" bignatCompareIdKey + , bignum_compare "bignatCompareWord#" bignatCompareWordIdKey -- binary operations - , integer_binop "integerAdd" integerAddName (+) - , integer_binop "integerSub" integerSubName (-) - , integer_binop "integerMul" integerMulName (*) - , integer_binop "integerGcd" integerGcdName gcd - , integer_binop "integerLcm" integerLcmName lcm - , integer_binop "integerAnd" integerAndName (.&.) - , integer_binop "integerOr" integerOrName (.|.) - , integer_binop "integerXor" integerXorName xor - - , natural_binop "naturalAdd" naturalAddName (+) - , natural_binop "naturalMul" naturalMulName (*) - , natural_binop "naturalGcd" naturalGcdName gcd - , natural_binop "naturalLcm" naturalLcmName lcm - , natural_binop "naturalAnd" naturalAndName (.&.) - , natural_binop "naturalOr" naturalOrName (.|.) - , natural_binop "naturalXor" naturalXorName xor + , integer_binop "integerAdd" integerAddIdKey (+) + , integer_binop "integerSub" integerSubIdKey (-) + , integer_binop "integerMul" integerMulIdKey (*) + , integer_binop "integerGcd" integerGcdIdKey gcd + , integer_binop "integerLcm" integerLcmIdKey lcm + , integer_binop "integerAnd" integerAndIdKey (.&.) + , integer_binop "integerOr" integerOrIdKey (.|.) + , integer_binop "integerXor" integerXorIdKey xor + + , natural_binop "naturalAdd" naturalAddIdKey (+) + , natural_binop "naturalMul" naturalMulIdKey (*) + , natural_binop "naturalGcd" naturalGcdIdKey gcd + , natural_binop "naturalLcm" naturalLcmIdKey lcm + , natural_binop "naturalAnd" naturalAndIdKey (.&.) + , natural_binop "naturalOr" naturalOrIdKey (.|.) + , natural_binop "naturalXor" naturalXorIdKey xor -- Natural subtraction: it's a binop but it can fail because of underflow so -- we have several primitives to handle here. - , natural_sub "naturalSubUnsafe" naturalSubUnsafeName - , natural_sub "naturalSubThrow" naturalSubThrowName - , mkRule "naturalSub" naturalSubName 2 $ do + , natural_sub "naturalSubUnsafe" naturalSubUnsafeIdKey + , natural_sub "naturalSubThrow" naturalSubThrowIdKey + , mkRule "naturalSub" naturalSubIdKey 2 $ do [a0,a1] <- getArgs x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 @@ -2278,53 +2297,53 @@ builtinBignumRules = else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations - , bignum_unop "integerNegate" integerNegateName mkIntegerExpr negate - , bignum_unop "integerAbs" integerAbsName mkIntegerExpr abs - , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement + , bignum_unop "integerNegate" integerNegateIdKey mkIntegerExpr negate + , bignum_unop "integerAbs" integerAbsIdKey mkIntegerExpr abs + , bignum_unop "integerComplement" integerComplementIdKey mkIntegerExpr complement - , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap - , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap + , bignum_popcount "integerPopCount" integerPopCountIdKey mkLitIntWrap + , bignum_popcount "naturalPopCount" naturalPopCountIdKey mkLitWordWrap -- Bits.bit - , bignum_bit "integerBit" integerBitName mkIntegerExpr - , bignum_bit "naturalBit" naturalBitName mkNaturalExpr + , bignum_bit "integerBit" integerBitIdKey mkIntegerExpr + , bignum_bit "naturalBit" naturalBitIdKey mkNaturalExpr -- Bits.testBit - , bignum_testbit "integerTestBit" integerTestBitName - , bignum_testbit "naturalTestBit" naturalTestBitName + , bignum_testbit "integerTestBit" integerTestBitIdKey + , bignum_testbit "naturalTestBit" naturalTestBitIdKey -- Bits.shift - , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr - , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr - , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr - , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr + , bignum_shift "integerShiftL" integerShiftLIdKey shiftL mkIntegerExpr + , bignum_shift "integerShiftR" integerShiftRIdKey shiftR mkIntegerExpr + , bignum_shift "naturalShiftL" naturalShiftLIdKey shiftL mkNaturalExpr + , bignum_shift "naturalShiftR" naturalShiftRIdKey shiftR mkNaturalExpr -- division - , divop_one "integerQuot" integerQuotName quot mkIntegerExpr - , divop_one "integerRem" integerRemName rem mkIntegerExpr - , divop_one "integerDiv" integerDivName div mkIntegerExpr - , divop_one "integerMod" integerModName mod mkIntegerExpr - , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr - , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr + , divop_one "integerQuot" integerQuotIdKey quot mkIntegerExpr + , divop_one "integerRem" integerRemIdKey rem mkIntegerExpr + , divop_one "integerDiv" integerDivIdKey div mkIntegerExpr + , divop_one "integerMod" integerModIdKey mod mkIntegerExpr + , divop_both "integerDivMod" integerDivModIdKey divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemIdKey quotRem mkIntegerExpr - , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr - , divop_one "naturalRem" naturalRemName rem mkNaturalExpr - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr + , divop_one "naturalQuot" naturalQuotIdKey quot mkNaturalExpr + , divop_one "naturalRem" naturalRemIdKey rem mkNaturalExpr + , divop_both "naturalQuotRem" naturalQuotRemIdKey quotRem mkNaturalExpr -- conversions from Rational for Float/Double literals - , rational_to "rationalToFloat#" rationalToFloatName LitFloat - , rational_to "rationalToDouble#" rationalToDoubleName LitDouble + , rational_to "rationalToFloat#" rationalToFloatIdKey LitFloat + , rational_to "rationalToDouble#" rationalToDoubleIdKey LitDouble -- conversions from Integer for Float/Double literals - , integer_encode_float "integerEncodeFloat" integerEncodeFloatName + , integer_encode_float "integerEncodeFloat" integerEncodeFloatIdKey encodeLitFloat LitFloat - , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName + , integer_encode_float "integerEncodeDouble" integerEncodeDoubleIdKey encodeLitDouble LitDouble ] where - mkRule str name nargs f = BuiltinRule + mkRule str key nargs f = BuiltinRule { ru_name = fsLit str - , ru_fn = name + , ru_key = key , ru_nargs = nargs , ru_try = runRuleM $ do env <- getRuleOpts @@ -2470,7 +2489,8 @@ builtinBignumRules = platform <- getPlatform pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] - integer_encode_float :: String -> Name -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule + integer_encode_float :: String -> KnownKeyNameKey + -> (Integer -> Int -> LitFloating) -> LitFloatingType -> CoreRule integer_encode_float str name encode_fun destType = mkRule str name 2 $ do [a0,a1] <- getArgs x <- isIntegerLiteral a0 @@ -2479,7 +2499,7 @@ builtinBignumRules = yInt <- liftMaybe (toIntegralSized y :: Maybe Int) pure $ Lit $ LitFloating destType $ encode_fun x yInt - rational_to :: String -> Name -> LitFloatingType -> CoreRule + rational_to :: String -> KnownKeyNameKey -> LitFloatingType -> CoreRule rational_to str name destType = mkRule str name 2 $ do -- This turns `rationalToFloat# n d` where `n` and `d` are literals into -- a literal Float# (and similarly for Double#). ===================================== compiler/GHC/Core/Ppr.hs ===================================== @@ -27,25 +27,27 @@ module GHC.Core.Ppr ( import GHC.Prelude import GHC.Core +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr +import GHC.Core.Coercion import GHC.Core.Stats (exprStats) + import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Literal( pprLiteral ) -import GHC.Types.Name( pprInfixName, pprPrefixName ) +import GHC.Types.Name( pprInfixName, pprPrefixName, pprKnownKey ) import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.InlinePragma import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr -import GHC.Core.Coercion +import GHC.Types.SrcLoc ( pprUserRealSpan ) +import GHC.Types.Tickish import GHC.Types.Basic + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.SrcLoc ( pprUserRealSpan ) -import GHC.Types.Tickish {- ************************************************************************ @@ -668,8 +670,8 @@ pprRules :: [CoreRule] -> SDoc pprRules rules = vcat (map pprRule rules) pprRule :: CoreRule -> SDoc -pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) - = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) +pprRule (BuiltinRule { ru_key = key, ru_name = name}) + = text "Built in rule for" <+> pprKnownKey key <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -79,8 +79,8 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set -import GHC.Types.Name.Env import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -357,7 +357,7 @@ addIdSpecialisations id rules addRulesToId :: RuleBase -> Id -> Id -- Add rules in the RuleBase to the rules in the Id addRulesToId rule_base bndr - | Just rules <- lookupNameEnv rule_base (idName bndr) + | Just rules <- lookupRuleBase rule_base (idUnique bndr) = bndr `addIdSpecialisations` rules | otherwise = bndr @@ -376,12 +376,12 @@ rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds -} -- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] +type RuleBase = UniqFM Unique [CoreRule] -- The rules are unordered; -- we sort out any overlaps on lookup emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv +emptyRuleBase = emptyUFM mkRuleBase :: [CoreRule] -> RuleBase mkRuleBase rules = extendRuleBaseList emptyRuleBase rules @@ -392,7 +392,10 @@ extendRuleBaseList rule_base new_guys extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + = addToUFM_Acc (:) Utils.singleton rule_base (ruleKey rule) rule + +lookupRuleBase :: RuleBase -> Unique -> Maybe [CoreRule] +lookupRuleBase = lookupUFM pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss -> @@ -440,9 +443,9 @@ addLocalRules rule_env rules = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv - , re_home_rules = emptyNameEnv - , re_eps_rules = emptyNameEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyRuleBase + , re_home_rules = emptyRuleBase + , re_eps_rules = emptyRuleBase , re_visible_orphs = emptyModuleSet } getRules :: RuleEnv -> Id -> [CoreRule] @@ -478,10 +481,10 @@ getRules (RuleEnv { re_local_rules = local_rule_base drop_orphs eps_rules ++ idCoreRules fn where - fn_name = idName fn + fn_key = idUnique fn drop_orphs [] = [] -- Fast path; avoid invoking recursive filter drop_orphs xs = filter (ruleIsVisible orphs) xs - get rb = lookupNameEnv rb fn_name `orElse` [] + get rb = lookupRuleBase rb fn_key `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True ===================================== compiler/GHC/HsToCore.hs ===================================== @@ -715,8 +715,8 @@ magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr) -- See Note [Wiring in unsafeCoerce#] for the defn we are creating here mkUnsafeCoercePrimPair _old_id old_expr - = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName - ; unsafe_equality_tc <- dsLookupTyCon unsafeEqualityTyConName + = do { unsafe_equality_proof_id <- dsLookupKnownKeyId unsafeEqualityProofIdKey + ; unsafe_equality_tc <- dsLookupKnownKeyTyCon unsafeEqualityTyConKey ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc ===================================== compiler/GHC/HsToCore/Match/Literal.hs ===================================== @@ -609,7 +609,7 @@ matchLiterals (var :| vars) ty sub_groups -- we can use a case expression; for String we need -- a chain of if-then-else ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName + do { eq_str <- dsLookupKnownKeyId eqStringIdKey ; mrs <- mapM (wrap_str_guard eq_str) alts ; return (foldr1 combineMatchResults mrs) } else ===================================== compiler/GHC/Tc/Deriv/Generate.hs ===================================== @@ -213,13 +213,29 @@ produced don't get through the typechecker. gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec) gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon , dit_rep_tc_args = tycon_args }) = do - do { eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - ; return ([mk_eq_bind eq_RDR], emptyBag) } + do { eq_RDR <- tcLookupKnownKey_RDR eqClassOpKey + ; ([mk_eq_bind eq_RDR], emptyBag) } where all_cons = getPossibleDataCons tycon tycon_args non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons - ------------------------------------------------------------------ + -- Generate tag check. See #17240 + eq_expr_with_tag_check = nlHsCase + (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] + (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) + [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr + , mkHsCaseAlt nlWildPat ( + nlHsCase + (nlHsVar a_RDR) + -- Only one branch to match all nullary constructors + -- as we already know the tags match but do not emit + -- the branch if there are no nullary constructors + (let non_nullary_pats = map pats_etc non_nullary_cons + in if null non_nullary_cons + then non_nullary_pats + else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) + ] + mk_eq_bind eq_RDR = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds where binds @@ -239,45 +255,29 @@ gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon | otherwise = [([a_Pat, b_Pat], eq_expr_with_tag_check)] - -- Generate tag check. See #17240 - eq_expr_with_tag_check = nlHsCase - (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR)))) - [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr - , mkHsCaseAlt nlWildPat ( - nlHsCase - (nlHsVar a_RDR) - -- Only one branch to match all nullary constructors - -- as we already know the tags match but do not emit - -- the branch if there are no nullary constructors - (let non_nullary_pats = map pats_etc non_nullary_cons - in if null non_nullary_cons - then non_nullary_pats - else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr])) - ] - - nested_eq_expr [] [] [] = true_Expr - nested_eq_expr tys as bs - = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs - -- Using 'foldr1' here ensures that the derived code is correctly - -- associated. See #10859. - where - nested_eq ty a b = nlHsPar (eq_Expr eq_RDR ty (nlHsVar a) (nlHsVar b)) + ------------------------------------------------------------------ + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs + -- Using 'foldr1' here ensures that the derived code is correctly + -- associated. See #10859. + where + nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b)) - gen_con_fields_and_tys data_con - | tys_needed <- derivDataConInstArgTys data_con dit - , con_arity <- length tys_needed - , as_needed <- take con_arity as_RDRs - , bs_needed <- take con_arity bs_RDRs - = (as_needed, bs_needed, tys_needed) + gen_con_fields_and_tys data_con + | tys_needed <- derivDataConInstArgTys data_con dit + , con_arity <- length tys_needed + , as_needed <- take con_arity as_RDRs + , bs_needed <- take con_arity bs_RDRs + = (as_needed, bs_needed, tys_needed) - pats_etc data_con - | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con - , data_con_RDR <- getRdrName data_con - , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed - , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed - , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed - = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) + pats_etc data_con + | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con + , data_con_RDR <- getRdrName data_con + , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed + , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed + , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed + = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr]) {- ************************************************************************ @@ -650,17 +650,16 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do -- See Note [Auxiliary binders] tag2con_RDR <- new_tag2con_rdr_name loc tycon maxtag_RDR <- new_maxtag_rdr_name loc tycon - eq_RDR <- rnLookupKnownKeyRdr eqClassOpKey - return ( method_binds eq_RDR tag2con_RDR maxtag_RDR + return ( method_binds tag2con_RDR maxtag_RDR , aux_binds tag2con_RDR maxtag_RDR ) where - method_binds eq_RDR tag2con_RDR maxtag_RDR = - [ succ_enum eq_RDR tag2con_RDR maxtag_RDR - , pred_enum eq_RDR tag2con_RDR - , to_enum tag2con_RDR maxtag_RDR - , enum_from tag2con_RDR maxtag_RDR -- [0 ..] - , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] + method_binds tag2con_RDR maxtag_RDR = + [ succ_enum tag2con_RDR maxtag_RDR + , pred_enum tag2con_RDR + , to_enum tag2con_RDR maxtag_RDR + , enum_from tag2con_RDR maxtag_RDR -- [0 ..] + , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..] , from_enum ] aux_binds tag2con_RDR maxtag_RDR = listToBag @@ -670,7 +669,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do occ_nm = getOccString tycon - succ_enum eq_RDR tag2con_RDR maxtag_RDR + succ_enum tag2con_RDR maxtag_RDR = mkSimpleGeneratedFunBind loc succ_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR, @@ -680,7 +679,7 @@ gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], nlHsIntLit 1])) - pred_enum eq_RDR tag2con_RDR + pred_enum tag2con_RDR = mkSimpleGeneratedFunBind loc pred_RDR (noLocA [a_Pat]) $ untag_Expr [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, @@ -2487,8 +2486,8 @@ and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: RdrName -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -eq_Expr eq_RDR ty a b +eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +eq_Expr ty a b | not (isUnliftedType ty) = genOpApp a eq_RDR b | otherwise = genPrimOpApp a prim_eq b where ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -515,7 +515,7 @@ mkDictSelId name clas -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` occNameFS (getOccName name) - , ru_fn = name + , ru_key = nameUnique name , ru_nargs = n_ty_args + 1 , ru_try = dictSelRule val_index n_ty_args } ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -127,6 +127,9 @@ A "known-key" name is one * but that's all that GHC knows about it In particular, GHC does /not/ know in which module the entity is defined. +See Note [Recipe for adding a known-key name] for +how to add a known-key name to GHC. + Example: the `Eq` class has OccName "Eq" and unique `eqClassKey`. It happens to be defined in ghc-internal:GHC.Internal.Classes, but GHC does not know that. @@ -245,6 +248,32 @@ Wrinkles (KKN1) We need some special treatment of unused-import warnings. See (UI1) in Note [Unused imports] in GHC.Rename.Names +Note [Recipe for adding a known-key name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To make `wombat` into a known-key name, you must ensure that: + +* The module M that defines `wombat` is compiled with `-fdefines-known-key-names`. + +* If M.hs has an `M.hs-boot` file, it too must be compiled + with `-fdefines-known-key-names`. + +* The module `GHC.KnownKeyNames` must export `wombat`. + +* The big list `GHC.Builtin.Names.knownKeyTable` must contain an + entry for `wombat`. + +* In any module in `base` or `ghc-internal` (which are compiled with + -frebindable-known-key-names), you must ensure that `wombat` is in scope + by saying `import M( wombat )`. + + If you just say `import M` you may get a "unused import" warning; that + warning is suppressed for known-key names if you import `wombat` by name. + + You do not need to import the module in which `wombat` is /defined/, although + you may. It is enough simply to bring `wombat` in scope by importing a + module that re-exports. You can even import `GHC.KnownKeyNames`, if that does + not create a module loop! + Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~ 1. Initially: ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -196,7 +196,7 @@ data RdrName -- we want to say \"Use Prelude.map dammit\". One of these -- can be created with 'mkOrig' - | Exact Name + | Exact ExactSpec -- ^ Exact name -- -- We know exactly the 'Name'. This is used: @@ -209,6 +209,11 @@ data RdrName -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' deriving Data +data ExactSpec + = ExactName Name -- Use this when you know the exact Name + | ExactKey KnownKeyNameKey -- Use this for known-key names + deriving Data + {- ************************************************************************ * * @@ -287,7 +292,7 @@ getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName -nameRdrName name = Exact name +nameRdrName name = Exact (ExactName name) -- Keep the Name even for Internal names, so that the -- unique is still there for debug printing, particularly -- of Types (which are converted to IfaceTypes before printing) ===================================== compiler/GHC/Types/Unique/FM.hs ===================================== @@ -176,6 +176,8 @@ addToUFM_C -> UniqFM key elt -- ^ old -> key -> elt -- ^ new -> UniqFM key elt -- ^ result +{-# SPECIALISE addToUFM_C :: (elt -> elt -> elt) -> UniqFM Unique elt + -> Unique -> elt -> UniqFM Unique elt #-} -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) @@ -197,6 +199,8 @@ addToUFM_Acc -> UniqFM key elts -- old -> key -> elt -- new -> UniqFM key elts -- result +{-# SPECIALISE addToUFM_Acc :: (elt -> elts -> elts) -> (elt->elts) -> UniqFM Unique elts + -> Unique -> elt -> UniqFM Unique elts #-} addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) ===================================== libraries/base/src/Data/Functor/Classes.hs ===================================== @@ -71,6 +71,8 @@ module Data.Functor.Classes ( showsBinary1, ) where +import GHC.KnownKeyNames + import Control.Applicative (Alternative((<|>)), Const(Const)) import GHC.Internal.Data.Functor.Identity (Identity(Identity)) @@ -90,6 +92,7 @@ import GHC.Internal.Text.Read.Lex (Lexeme(..)) import GHC.Internal.Text.Show (showListWith) import Prelude + -- $setup -- >>> import Prelude -- >>> import Data.Complex (Complex (..)) ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy, RankNTypes #-} +{-# LANGUAGE MagicHash, Trustworthy, RankNTypes #-} {-# OPTIONS_GHC -fdefines-known-key-names #-} -- See Note [Known-key names and IsList] @@ -32,6 +32,7 @@ module GHC.KnownKeyNames , Num, Integral, Real , (-), negate, fromInteger, fromRational , mkRationalBase2, mkRationalBase10 + , divInt#, modInt# -- Strings , IsString @@ -47,12 +48,37 @@ module GHC.KnownKeyNames -- IO , thenIO, bindIO, returnIO, print + + -- Names that have BuiltinRules + , CS.unpackFoldrCString#, CS.unpackFoldrCStringUtf8#, CS.unpackAppendCString# + , CS.unpackAppendCStringUtf8#, CS.cstringLength# + , eqString, inline + + , UnsafeEquality( UnsafeRefl ), unsafeEqualityProof + + -- Bignums + , bigNatEq#, bigNatCompare, bigNatCompareWord# + , naturalToWord#, naturalPopCount#, naturalShiftR#, naturalShiftL# + , naturalAdd, naturalSub, naturalSubThrow, naturalSubUnsafe + , naturalMul, naturalQuotRem#, naturalQuot, naturalRem, naturalAnd + , naturalOr, naturalXor, naturalTestBit#, naturalBit#, naturalGcd, naturalLcm + + , integerFromNatural, integerToNaturalClamp, integerToNaturalThrow, integerToNatural + , integerToWord#, integerToInt#, integerToWord64#, integerToInt64#, integerFromWord# + , integerFromWord64#, integerFromInt64#, integerAdd, integerMul, integerSub + , integerNegate, integerAbs, integerPopCount#, integerQuot, integerRem, integerDiv + , integerMod, integerDivMod#, integerQuotRem#, integerEncodeFloat#, integerEncodeDouble# + , integerGcd, integerLcm, integerAnd, integerOr, integerXor + , integerComplement, integerBit#, integerTestBit#, integerShiftL#, integerShiftR# ) where import Prelude import Data.String( IsString ) -import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO ) +import GHC.Internal.Base( Alternative, join, thenIO, bindIO, returnIO + , eqString ) +import GHC.Internal.Classes( divInt#, modInt# ) import GHC.Internal.Ix( Ix ) +import GHC.Internal.Magic( inline ) import GHC.Internal.Data.Data( Data ) import GHC.Internal.Data.String( fromString ) import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) @@ -62,12 +88,20 @@ import GHC.Internal.Control.Monad.Zip( mzip ) import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) import GHC.Internal.OverloadedLabels( fromLabel ) import GHC.Internal.Records( HasField, getField ) +import GHC.Internal.CString as CS import qualified GHC.Internal.IsList as IL +import GHC.Internal.Unsafe.Coerce( UnsafeEquality(..), unsafeEqualityProof ) + +import GHC.Internal.Bignum.Integer +import GHC.Internal.Bignum.Natural +import GHC.Internal.Bignum.BigNat + {- Note [Known-key names and IsList] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Very annoyingly both the classes Foldable and IsList have a method `toList`. we can't have two known-key names with the same OccName. + -} isList_toList :: IL.IsList l => l -> [IL.Item l] ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs ===================================== @@ -9,6 +9,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE BinaryLiterals #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + {-# OPTIONS_GHC -Wno-name-shadowing #-} -- | Multi-precision natural ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/BigNat.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.BigNat where import GHC.Internal.Bignum.WordArray ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs ===================================== @@ -8,6 +8,9 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + -- | -- Module : GHC.Internal.Bignum.Integer -- Copyright : (c) Sylvain Henry 2019, ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs-boot ===================================== @@ -2,6 +2,9 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Integer where import GHC.Internal.Types ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs ===================================== @@ -5,6 +5,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + #include "MachDeps.h" #include "WordSize.h" ===================================== libraries/ghc-internal/src/GHC/Internal/Bignum/Natural.hs-boot ===================================== @@ -1,6 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines lots of functions that have BuiltinRules + module GHC.Internal.Bignum.Natural where import {-# SOURCE #-} GHC.Internal.Bignum.BigNat ===================================== libraries/ghc-internal/src/GHC/Internal/CString.hs ===================================== @@ -1,4 +1,8 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns, UnliftedFFITypes #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unpackFoldrCString# etc + ----------------------------------------------------------------------------- -- | -- Module : GHC.Internal.CString ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Const.hs ===================================== @@ -25,9 +25,7 @@ import GHC.Internal.Data.Foldable (Foldable(foldMap)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monoid(..), Semigroup(..), ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -36,6 +34,7 @@ import GHC.Internal.Prim (coerce) import GHC.Internal.Real (Fractional, Integral, Real, RealFrac) import GHC.Internal.Read (Read(readsPrec), readParen, lex) import GHC.Internal.Show (Show(showsPrec), showParen, showString) + import GHC.Internal.Num( fromInteger ) -- For known-key names -- | The 'Const' functor. ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Functor/Identity.hs ===================================== @@ -34,12 +34,11 @@ module GHC.Internal.Data.Functor.Identity ( import GHC.Internal.Data.Bits (Bits, FiniteBits) import GHC.Internal.Data.Coerce -import GHC.Internal.Data.Foldable +import GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Functor.Utils ((#.)) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( Applicative(..), Functor(..), Monad(..) - , Semigroup, Monoid, ($), (.) ) +import GHC.Internal.Base import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Enum (Bounded, Enum) import GHC.Internal.Float (Floating, RealFloat) @@ -117,7 +116,7 @@ instance Foldable Identity where foldl' = coerce foldl1 _ = runIdentity foldr f z (Identity x) = f x z - foldr' = foldr + foldr' = Foldable.foldr -- Not the one from GHC.Internal.Base! foldr1 _ = runIdentity length _ = 1 maximum = runIdentity ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Ord.hs ===================================== @@ -28,10 +28,7 @@ import GHC.Internal.Classes (Eq(..), Ord(..)) import GHC.Internal.Data.Bits (Bits, FiniteBits, complement) import GHC.Internal.Foreign.Storable (Storable) import GHC.Internal.Ix (Ix) -import GHC.Internal.Base ( - Applicative(..), Functor(..), Monad(..), Monoid, Semigroup, otherwise, - ($), (.), - ) +import GHC.Internal.Base import GHC.Internal.Enum (Bounded(..), Enum(..)) import GHC.Internal.Float (Floating, RealFloat) import GHC.Internal.Num ===================================== libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs ===================================== @@ -124,6 +124,7 @@ import {-# SOURCE #-} GHC.Internal.Fingerprint -- import {-# SOURCE #-} GHC.Internal.Debug.Trace (trace) import GHC.Internal.Num( fromInteger ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names #include "MachDeps.h" ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Encoding.hs ===================================== @@ -36,7 +36,7 @@ module GHC.Internal.IO.Encoding ( argvEncoding ) where -import GHC.Internal.Base (String, return, ($)) +import GHC.Internal.Base (String, return, ($), eqString) import GHC.Internal.Classes (Eq(..)) import GHC.Internal.IO.Exception import GHC.Internal.IO.Buffer ===================================== libraries/ghc-internal/src/GHC/Internal/Magic.hs ===================================== @@ -5,6 +5,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines inline etc + {-# OPTIONS_HADDOCK print-explicit-runtime-reps #-} ----------------------------------------------------------------------------- ===================================== libraries/ghc-internal/src/GHC/Internal/Read.hs ===================================== @@ -83,6 +83,7 @@ import GHC.Internal.Tuple (Solo (..)) import GHC.Internal.ByteOrder import GHC.Internal.Control.Monad.Fail( fail ) -- For known-key names +import GHC.Internal.Base( eqString ) -- For known-key names -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with -- parentheses. ===================================== libraries/ghc-internal/src/GHC/Internal/Unsafe/Coerce.hs ===================================== @@ -3,6 +3,9 @@ -- Note [Implementing unsafeCoerce] {-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines unsafeEqualityProof etc + {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/809c39eee41eccd03294fbc3d7bcf24… You're receiving this email because of your account on gitlab.haskell.org.

1 0