[Git][ghc/ghc][wip/T17521] 2 commits: Better test

[Jaro Reinders (@Noughtmare)]

Jaro Reinders pushed to branch wip/T17521 at Glasgow Haskell Compiler / GHC


Commits:
03a9fa96 by Jaro Reinders at 2023-07-13T16:59:05+02:00
Better test

- - - - -
0891b558 by Jaro Reinders at 2023-07-13T17:01:56+02:00
Relax lint

- - - - -


8 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/Stg/Lint.hs
- testsuite/tests/unlifted-datatypes/should_run/TopLevel.hs → testsuite/tests/unlifted-datatypes/should_compile/TopLevel.hs
- + testsuite/tests/unlifted-datatypes/should_compile/TopLevel.stderr
- testsuite/tests/unlifted-datatypes/should_run/TopLevela.hs → testsuite/tests/unlifted-datatypes/should_compile/TopLevela.hs
- testsuite/tests/unlifted-datatypes/should_compile/all.T
- − testsuite/tests/unlifted-datatypes/should_run/TopLevel.stdout
- testsuite/tests/unlifted-datatypes/should_run/all.T


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -577,13 +577,15 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
        ; checkL (not (isCoVar binder) || isCoArg rhs)
                 (mkLetErr binder rhs)
 
-        -- Check the let-can-float invariant
+        -- Check the let-can-float and letrec invariants
         -- See Note [Core let-can-float invariant] in GHC.Core
+        -- See Note [Core letrec invariant] in GHC.Core
        ; checkL ( isJoinId binder
                || mightBeLiftedType binder_ty
                || (isNonRec rec_flag && exprOkForSpeculation rhs)
                || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed
-               || exprIsTickedString rhs)
+               || exprIsTickedString rhs
+               || isTopLevel top_lvl && isBoxedType rhs_ty && isJust (do (Var v, xs) <- pure (collectArgs rhs); pure (isDataConWorkId v && all exprIsTrivial xs)))
            (badBndrTyMsg binder (text "unlifted"))
 
         -- Check that if the binder is at the top level and has type Addr#,


=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -209,7 +209,8 @@ lint_binds_help top_lvl (binder, rhs)
         -- Check binder doesn't have unlifted type or it's a join point
         checkL ( isJoinId binder
               || not (isUnliftedType (idType binder))
-              || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
+              || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed
+              || isTopLevel top_lvl && isBoxedType (idType binder) && case rhs of StgRhsCon{} -> True; _ -> False)
           (mkUnliftedTyMsg opts binder rhs)
 
 -- | Top-level bindings can't inherit the cost centre stack from their


=====================================
testsuite/tests/unlifted-datatypes/should_run/TopLevel.hs → testsuite/tests/unlifted-datatypes/should_compile/TopLevel.hs
=====================================


=====================================
testsuite/tests/unlifted-datatypes/should_compile/TopLevel.stderr
=====================================
@@ -0,0 +1,18 @@
+[1 of 3] Compiling TopLevela        ( TopLevela.hs, TopLevela.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 12, types: 6, coercions: 0, joins: 0/0}
+
+x3 = USucc UZero
+
+x2 = USucc x3
+
+x1 = USucc x2
+
+x = Box x1
+
+
+
+[2 of 3] Compiling Main             ( TopLevel.hs, TopLevel.o )
+[3 of 3] Linking TopLevel


=====================================
testsuite/tests/unlifted-datatypes/should_run/TopLevela.hs → testsuite/tests/unlifted-datatypes/should_compile/TopLevela.hs
=====================================
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -ddump-simpl -ddump-simpl -dsuppress-all -dno-typeable-binds -dsuppress-uniques #-}
 {-# LANGUAGE UnliftedDatatypes #-}
 module TopLevela where
 


=====================================
testsuite/tests/unlifted-datatypes/should_compile/all.T
=====================================
@@ -2,3 +2,4 @@ test('UnlDataMonoSigs', normal, compile, [''])
 test('UnlDataPolySigs', normal, compile, [''])
 test('UnlDataFams', normal, compile, [''])
 test('UnlDataUsersGuide', normal, compile, [''])
+test('TopLevel', normal, multimod_compile, ['TopLevel', '-O'])


=====================================
testsuite/tests/unlifted-datatypes/should_run/TopLevel.stdout deleted
=====================================
@@ -1 +0,0 @@
-3
\ No newline at end of file


=====================================
testsuite/tests/unlifted-datatypes/should_run/all.T
=====================================
@@ -1,4 +1,3 @@
 test('UnlData1', normal, compile_and_run, [''])
 test('UnlGadt1', [exit_code(1), expect_broken_for(23060, ghci_ways)], compile_and_run, [''])
-test('T23549', normal, multimod_compile_and_run, ['T23549', ''])
-test('TopLevel', normal, multimod_compile_and_run, ['TopLevel', '-O'])
\ No newline at end of file
+test('T23549', normal, multimod_compile_and_run, ['T23549', ''])
\ No newline at end of file



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e59dd7947ae0da96da5b60ff7d3042ae7cd54de...0891b558ad08124d8e1a53f14fd68805cb02e711

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e59dd7947ae0da96da5b60ff7d3042ae7cd54de...0891b558ad08124d8e1a53f14fd68805cb02e711
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/20230713/4918574e/attachment-0001.html>