[Git][ghc/ghc][wip/T18151] 2 commits: testsuite: Add test for #18151

[Ben Gamari]

Ben Gamari pushed to branch wip/T18151 at Glasgow Haskell Compiler / GHC


Commits:
c32cbf39 by Ben Gamari at 2020-05-10T21:24:20-04:00
testsuite: Add test for #18151

- - - - -
e4ec8175 by Ben Gamari at 2020-05-10T21:24:59-04:00
HsToCore: Eta expand left sections

Strangely, the comment next to this code already alluded to the fact
that even simply eta-expanding will sacrifice laziness. It's quite
unclear how we regressed so far.

See #18151.

- - - - -


4 changed files:

- compiler/GHC/HsToCore/Expr.hs
- + testsuite/tests/deSugar/should_run/T18151.hs
- + testsuite/tests/deSugar/should_run/T18151.stdout
- testsuite/tests/deSugar/should_run/all.T


Changes:

=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -338,26 +338,25 @@ Then we get
 That 'g' in the 'in' part is an evidence variable, and when
 converting to core it must become a CO.
 
+
+Note [Desugaring operator sections]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Operator sections.  At first it looks as if we can convert
-\begin{verbatim}
-        (expr op)
-\end{verbatim}
+    (expr op)
 to
-\begin{verbatim}
-        \x -> op expr x
-\end{verbatim}
+    \x -> op expr x
 
 But no!  expr might be a redex, and we can lose laziness badly this
 way.  Consider
-\begin{verbatim}
-        map (expr op) xs
-\end{verbatim}
-for example.  So we convert instead to
-\begin{verbatim}
-        let y = expr in \x -> op y x
-\end{verbatim}
+    map (expr op) xs
+for example.
+
+So we convert instead to
+    let y = expr in \x -> op y x
 If \tr{expr} is actually just a variable, say, then the simplifier
 will sort it out.
+
+See #18151.
 -}
 
 dsExpr e@(OpApp _ e1 op e2)
@@ -366,17 +365,24 @@ dsExpr e@(OpApp _ e1 op e2)
        ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
                       (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
 
-dsExpr (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
-  = do { op' <- dsLExpr op
-       ; dsWhenNoErrs (dsLExprNoLP expr)
-                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
+-- dsExpr (SectionL op expr)  ===  (expr `op`)  ~>  \y -> op expr y
+--
+-- See Note [Desugaring operator sections]
+dsExpr (SectionL _ expr op) = do
+    core_op <- dsLExpr op
+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+    x_core <- dsLExpr expr
+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
+                 (\[x_id, y_id] -> bindNonRec x_id x_core $
+                                   Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)
+                                                          core_op [Var x_id, Var y_id]))
 
--- dsLExpr (SectionR op expr)   -- \ x -> op x expr
+-- dsExpr (SectionR op expr)  === (`op` expr)  ~>  \x -> op x expr
+--
+-- See Note [Desugaring operator sections]
 dsExpr e@(SectionR _ op expr) = do
     core_op <- dsLExpr op
-    -- for the type of x, we need the type of op's 2nd argument
     let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
-        -- See comment with SectionL
     y_core <- dsLExpr expr
     dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
                  (\[x_id, y_id] -> bindNonRec y_id y_core $


=====================================
testsuite/tests/deSugar/should_run/T18151.hs
=====================================
@@ -0,0 +1,10 @@
+-- According to the Report this should reduce to (). However, in #18151 it was
+-- reported that GHC bottoms.
+x :: ()
+x = seq (True `undefined`) ()
+{-# NOINLINE x #-}
+
+main :: IO ()
+main = do
+  print x
+


=====================================
testsuite/tests/deSugar/should_run/T18151.stdout
=====================================
@@ -0,0 +1 @@
+()
\ No newline at end of file


=====================================
testsuite/tests/deSugar/should_run/all.T
=====================================
@@ -63,3 +63,4 @@ test('T11601', exit_code(1), compile_and_run, [''])
 test('T11747', normal, compile_and_run, ['-dcore-lint'])
 test('T12595', normal, compile_and_run, [''])
 test('T13285', normal, compile_and_run, [''])
+test('T18151', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75efdfd8994f0c6d19112a22e0b651271fd10053...e4ec81757288d7003eb8407e529d0a1a64ebc040

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/75efdfd8994f0c6d19112a22e0b651271fd10053...e4ec81757288d7003eb8407e529d0a1a64ebc040
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/20200510/8a9fb105/attachment-0001.html>