[Git][ghc/ghc][master] Make 'undefined x' linear in 'x' (#18731)

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
bda55fa0 by Krzysztof Gogolewski at 2020-09-26T13:18:22-04:00
Make 'undefined x' linear in 'x' (#18731)

- - - - -


3 changed files:

- compiler/GHC/Tc/Gen/App.hs
- + testsuite/tests/linear/should_compile/T18731.hs
- testsuite/tests/linear/should_compile/all.T


Changes:

=====================================
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


=====================================
testsuite/tests/linear/should_compile/T18731.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE LinearTypes #-}
+module T18731 where
+
+f :: a #-> b
+f x = undefined x


=====================================
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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bda55fa0444310079ab89f2d28ddb8982975b646

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bda55fa0444310079ab89f2d28ddb8982975b646
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/20200926/25753d61/attachment-0001.html>