diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-09-21 17:49:43 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-09-26 13:18:22 -0400 |
| commit | bda55fa0444310079ab89f2d28ddb8982975b646 (patch) | |
| tree | 04f6a2515d81b3ca3c0da3d8c072cd40cd3fdd80 | |
| parent | 1cde295c543e209c3b81256b50e77f3c5132a4ad (diff) | |
| download | haskell-bda55fa0444310079ab89f2d28ddb8982975b646.tar.gz | |
Make 'undefined x' linear in 'x' (#18731)
| -rw-r--r-- | compiler/GHC/Tc/Gen/App.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_compile/T18731.hs | 5 | ||||
| -rw-r--r-- | testsuite/tests/linear/should_compile/all.T | 1 |
3 files changed, 13 insertions, 2 deletions
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 79749c70c7..702149784d 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -19,6 +19,7 @@ module GHC.Tc.Gen.App import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC ) +import GHC.Builtin.Types (multiplicityTy) import GHC.Tc.Gen.Head import GHC.Hs import GHC.Tc.Utils.Monad @@ -499,13 +500,17 @@ tcInstFun do_ql inst_final rn_fun fun_sigma rn_args -- - We need the freshly allocated unification variables, to extend -- delta with. -- It's easier just to do the job directly here. - do { arg_nus <- replicateM (countLeadingValArgs args) newOpenFlexiTyVar + do { let valArgsCount = countLeadingValArgs args + ; arg_nus <- replicateM valArgsCount newOpenFlexiTyVar + -- We need variables for multiplicity (#18731) + -- Otherwise, 'undefined x' wouldn't be linear in x + ; mults <- replicateM valArgsCount (newFlexiTyVarTy multiplicityTy) ; res_nu <- newOpenFlexiTyVar ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa) ; let delta' = delta `extendVarSetList` (res_nu:arg_nus) arg_tys = mkTyVarTys arg_nus res_ty = mkTyVarTy res_nu - fun_ty' = mkVisFunTysMany arg_tys res_ty + fun_ty' = mkVisFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty co_wrap = mkWpCastN (mkTcGReflLeftCo Nominal fun_ty' kind_co) acc' = addArgWrap co_wrap acc -- Suppose kappa :: kk diff --git a/testsuite/tests/linear/should_compile/T18731.hs b/testsuite/tests/linear/should_compile/T18731.hs new file mode 100644 index 0000000000..c7899efb54 --- /dev/null +++ b/testsuite/tests/linear/should_compile/T18731.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE LinearTypes #-} +module T18731 where + +f :: a #-> b +f x = undefined x diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T index 5a4b47c269..d624a337ba 100644 --- a/testsuite/tests/linear/should_compile/all.T +++ b/testsuite/tests/linear/should_compile/all.T @@ -36,3 +36,4 @@ test('LinearLetRec', expect_broken(405), compile, ['-O -dlinear-core-lint']) test('LinearTH1', normal, compile, ['']) test('LinearTH2', expect_broken(broken_multiplicity_syntax), compile, ['']) test('LinearHole', normal, compile, ['']) +test('T18731', normal, compile, ['']) |