[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: JS: `h$rts_isProfiled` is removed from `profiling` and left its version at
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Mar 28 20:12:07 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
13223f6d by Serge S. Gulin at 2024-03-27T07:28:51-04:00
JS: `h$rts_isProfiled` is removed from `profiling` and left its version at
`rts/js/config.js`
- - - - -
0acfe391 by Alan Zimmerman at 2024-03-27T07:29:27-04:00
EPA: Do not extend declaration range for trailine zero len semi
The lexer inserts virtual semicolons having zero width.
Do not use them to extend the list span of items in a list.
- - - - -
e5054075 by Ben Gamari at 2024-03-28T16:11:55-04:00
compiler: Allow more types in GHCForeignImportPrim
For many, many years `GHCForeignImportPrim` has suffered from the rather
restrictive limitation of not allowing any non-trivial types in arguments
or results. This limitation was justified by the code generator allegely
barfing in the presence of such types.
However, this restriction appears to originate well before the NCG
rewrite and the new NCG does not appear to have any trouble with such
types (see the added `T24598` test). Lift this restriction.
Fixes #24598.
- - - - -
78bf1813 by Alan Zimmerman at 2024-03-28T16:11:55-04:00
EPA: Fix FamDecl range
The span was incorrect if opt_datafam_kind_sig was empty
- - - - -
2f522372 by Ben Gamari at 2024-03-28T16:11:55-04:00
Fix type of _get_osfhandle foreign import
Fixes #24601.
- - - - -
18 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Runtime/Utils.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- rts/js/profiling.js
- testsuite/tests/ffi/should_fail/ccfail001.stderr
- + testsuite/tests/ffi/should_run/T24598.hs
- + testsuite/tests/ffi/should_run/T24598.stdout
- + testsuite/tests/ffi/should_run/T24598_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598b.hs
- + testsuite/tests/ffi/should_run/T24598b.stdout
- + testsuite/tests/ffi/should_run/T24598b_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598c.hs
- + testsuite/tests/ffi/should_run/T24598c.stdout
- + testsuite/tests/ffi/should_run/T24598c_cmm.cmm
- testsuite/tests/ffi/should_run/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/PprLetIn.hs
- testsuite/tests/printer/all.T
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -1313,7 +1313,7 @@ ty_decl :: { LTyClDecl GhcPs }
-- data/newtype family
| 'data' 'family' type opt_datafam_kind_sig
- {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3
+ {% mkFamDecl (comb4 $1 $2 $3 $4) DataFamily TopLevel $3
(snd $ unLoc $4) Nothing
(mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }
@@ -1438,10 +1438,10 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
h' <- addTrailingSemiA h (gl $2)
return (sLL $1 $> ($3 : h' : t)) }
| ty_fam_inst_eqns ';' {% case unLoc $1 of
- [] -> return (sLL $1 $> (unLoc $1))
+ [] -> return (sLZ $1 $> (unLoc $1))
(h:t) -> do
h' <- addTrailingSemiA h (gl $2)
- return (sLL $1 $> (h':t)) }
+ return (sLZ $1 $> (h':t)) }
| ty_fam_inst_eqn { sLL $1 $> [$1] }
| {- empty -} { noLoc [] }
@@ -1719,12 +1719,12 @@ decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
return (sLL $1 $> (fst $ unLoc $1
, snocOL hs t' `appOL` unitOL $3)) }
| decls_cls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)
+ then return (sLZ $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)
,snd $ unLoc $1))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
t' <- addTrailingSemiA t (gl $2)
- return (sLL $1 $> (fst $ unLoc $1
+ return (sLZ $1 $> (fst $ unLoc $1
, snocOL hs t')) }
| decl_cls { sL1 $1 ([], unitOL $1) }
| {- empty -} { noLoc ([],nilOL) }
@@ -1765,12 +1765,12 @@ decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed
return (sLL $1 $> (fst $ unLoc $1
, snocOL hs t' `appOL` unLoc $3)) }
| decls_inst ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ then return (sLZ $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
,snd $ unLoc $1))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
t' <- addTrailingSemiA t (gl $2)
- return (sLL $1 $> (fst $ unLoc $1
+ return (sLZ $1 $> (fst $ unLoc $1
, snocOL hs t')) }
| decl_inst { sL1 $1 ([],unLoc $1) }
| {- empty -} { noLoc ([],nilOL) }
@@ -1806,12 +1806,12 @@ decls :: { Located ([AddEpAnn], OrdList (LHsDecl GhcPs)) }
return (rest `seq` this `seq` these `seq`
(sLL $1 $> (fst $ unLoc $1, these))) }
| decls ';' {% if isNilOL (snd $ unLoc $1)
- then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemiA $2)
+ then return (sLZ $1 $> (((fst $ unLoc $1) ++ (msemiA $2)
,snd $ unLoc $1)))
else case (snd $ unLoc $1) of
SnocOL hs t -> do
t' <- addTrailingSemiA t (gl $2)
- return (sLL $1 $> (fst $ unLoc $1
+ return (sLZ $1 $> (fst $ unLoc $1
, snocOL hs t')) }
| decl { sL1 $1 ([], unitOL $1) }
| {- empty -} { noLoc ([],nilOL) }
@@ -3334,11 +3334,11 @@ alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs
return (sLL $1 $> (fst $ unLoc $1,$3 : h' : t)) }
| alts1(PATS) ';' { $1 >>= \ $1 ->
case snd $ unLoc $1 of
- [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
+ [] -> return (sLZ $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)
,[]))
(h:t) -> do
h' <- addTrailingSemiA h (gl $2)
- return (sLL $1 $> (fst $ unLoc $1, h' : t)) }
+ return (sLZ $1 $> (fst $ unLoc $1, h' : t)) }
| alt(PATS) { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }
alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
@@ -3442,7 +3442,7 @@ stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (
| stmts ';' { $1 >>= \ $1 ->
case (snd $ unLoc $1) of
- [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))
+ [] -> return (sLZ $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))
(h:t) -> do
{ h' <- addTrailingSemiA h (gl $2)
; return $ sL1 $1 (fst $ unLoc $1,h':t) }}
@@ -3552,7 +3552,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
| dbinds ';' {% case unLoc $1 of
(h:t) -> do
h' <- addTrailingSemiA h (gl $2)
- return (sLL $1 $> (h':t)) }
+ return (sLZ $1 $> (h':t)) }
| dbind { let this = $1 in this `seq` (sL1 $1 [this]) }
-- | {- empty -} { [] }
@@ -4195,6 +4195,12 @@ sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c
sLLAsl [] = sL1
sLLAsl (!x:_) = sLL x
+{-# INLINE sLZ #-}
+sLZ :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c
+sLZ !x !y = if isZeroWidthSpan (getHasLoc y)
+ then sL (getHasLoc x)
+ else sL (comb2 x y)
+
{- Note [Adding location info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Runtime/Utils.hs
=====================================
@@ -29,7 +29,7 @@ foreign import ccall "io.h _close"
c__close :: CInt -> IO CInt
foreign import ccall unsafe "io.h _get_osfhandle"
- _get_osfhandle :: CInt -> IO CInt
+ _get_osfhandle :: CInt -> IO CIntPtr
runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle)
-> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle)
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -84,7 +84,6 @@ import Control.Monad.Trans.Writer.CPS
import Control.Monad.Trans.Class
( lift )
import Data.Maybe (isJust)
-import GHC.Types.RepType (tyConPrimRep)
import GHC.Builtin.Types (unitTyCon)
-- Defines a binding
@@ -737,7 +736,6 @@ marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| otherwise
= boxedMarshalableTyCon tc
@@ -772,7 +770,6 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledRe
-- types and also unboxed tuple and sum result types.
legalFIPrimResultTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
@@ -786,13 +783,3 @@ validIfUnliftedFFITypes dflags
| xopt LangExt.UnliftedFFITypes dflags = IsValid
| otherwise = NotValid UnliftedFFITypesNeeded
-{-
-Note [Marshalling void]
-~~~~~~~~~~~~~~~~~~~~~~~
-We don't treat State# (whose PrimRep is VoidRep) as marshalable.
-In turn that means you can't write
- foreign import foo :: Int -> State# RealWorld
-
-Reason: the back end falls over with panic "primRepHint:VoidRep";
- and there is no compelling reason to permit it
--}
=====================================
rts/js/profiling.js
=====================================
@@ -331,7 +331,3 @@ function h$buildCCSPtr(o) {
function h$clearCCS(a) {
throw new Error("ClearCCSOp not implemented");
}
-
-function h$rts_isProfiled() {
- return 0;
-}
=====================================
testsuite/tests/ffi/should_fail/ccfail001.stderr
=====================================
@@ -1,6 +1,8 @@
-ccfail001.hs:10:1: error: [GHC-89401]
+ccfail001.hs:10:1: error: [GHC-10964]
• Unacceptable result type in foreign declaration:
‘State# RealWorld’ cannot be marshalled in a foreign call
+ UnliftedFFITypes is required to marshal unlifted types
• When checking declaration:
foreign import ccall safe foo :: Int -> State# RealWorld
+ Suggested fix: Perhaps you intended to use UnliftedFFITypes
=====================================
testsuite/tests/ffi/should_run/T24598.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in results correctly.
+module Main where
+
+import GHC.IO
+import GHC.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello >>= print
+
+hello :: IO Int
+hello = IO $ \s -> case hello# s of (# s', n# #) -> (# s', I# n# #)
=====================================
testsuite/tests/ffi/should_run/T24598.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello() {
+ return (42);
+}
=====================================
testsuite/tests/ffi/should_run/T24598b.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in arguments correctly.
+module Main where
+
+import GHC.IO
+import GHC.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello 21 >>= print
+
+hello :: Int -> IO Int
+hello (I# n#) = IO $ \s ->
+ case hello# n# s of (# s', n# #) -> (# s', I# n# #)
+
=====================================
testsuite/tests/ffi/should_run/T24598b.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598b_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello(W_ n) {
+ return (2*n);
+}
=====================================
testsuite/tests/ffi/should_run/T24598c.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in arguments correctly.
+module Main where
+
+import GHC.IO
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> State# RealWorld
+
+main :: IO ()
+main = hello
+
+hello :: IO ()
+hello = IO $ \s ->
+ case hello# s of s' -> (# s', () #)
+
=====================================
testsuite/tests/ffi/should_run/T24598c.stdout
=====================================
@@ -0,0 +1 @@
+hello
=====================================
testsuite/tests/ffi/should_run/T24598c_cmm.cmm
=====================================
@@ -0,0 +1,11 @@
+#include "Cmm.h"
+
+section "data" {
+ test_str: bits8[] "hello";
+}
+
+hello() {
+ ccall puts(test_str);
+ return ();
+}
+
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -268,3 +268,7 @@ test('T24314',
# libffi-wasm doesn't support more than 4 args yet
when(arch('wasm32'), skip)],
compile_and_run, ['T24314_c.c'])
+
+test('T24598', req_cmm, compile_and_run, ['T24598_cmm.cmm'])
+test('T24598b', req_cmm, compile_and_run, ['T24598b_cmm.cmm'])
+test('T24598c', req_cmm, compile_and_run, ['T24598c_cmm.cmm'])
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -821,3 +821,8 @@ AnnotationNoListTuplePuns:
Test24533:
$(CHECK_PPR) $(LIBDIR) Test24533.hs
$(CHECK_EXACT) $(LIBDIR) Test24533.hs
+
+.PHONY: PprLetIn
+PprLetIn:
+ $(CHECK_PPR) $(LIBDIR) PprLetIn.hs
+ $(CHECK_EXACT) $(LIBDIR) PprLetIn.hs
=====================================
testsuite/tests/printer/PprLetIn.hs
=====================================
@@ -0,0 +1,5 @@
+module PprLetIn where
+
+ff = let
+ x = 1
+ in 4
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -197,3 +197,4 @@ test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
test('ListTuplePuns', extra_files(['ListTuplePuns.hs']), ghci_script, ['ListTuplePuns.script'])
test('AnnotationNoListTuplePuns', [ignore_stderr, req_ppr_deps], makefile_test, ['AnnotationNoListTuplePuns'])
test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
+test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d686560e3d994c23e32cfe4da823b221d080520...2f522372a4d5ef887cf93d2843b8365683b2e60b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d686560e3d994c23e32cfe4da823b221d080520...2f522372a4d5ef887cf93d2843b8365683b2e60b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240328/dd9f4592/attachment-0001.html>
More information about the ghc-commits
mailing list