[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: JS: Fix implementation of MK_JSVAL

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
bab23279 by Josh Meredith at 2023-03-10T23:24:49-05:00
JS: Fix implementation of MK_JSVAL

- - - - -
ec263a59 by Sebastian Graf at 2023-03-10T23:25:25-05:00
Simplify: Move `wantEtaExpansion` before expensive `do_eta_expand` check

There is no need to run arity analysis and what not if we are not in a
Simplifier phase that eta-expands or if we don't want to eta-expand the
expression in the first place.

Purely a refactoring with the goal of improving compiler perf.

- - - - -
047e9d4f by Josh Meredith at 2023-03-13T03:56:03+00:00
JS: fix implementation of forceBool to use JS backend syntax

- - - - -
d55dacfe by Sebastian Graf at 2023-03-13T05:00:42-04:00
Simplifier: `countValArgs` should not count Type args (#23102)

I observed miscompilations while working on !10088 caused by this.

Fixes #23102.

Metric Decrease:
    T10421

- - - - -


6 changed files:

- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/HsToCore/Foreign/JavaScript.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- + testsuite/tests/javascript/T23101.hs
- + testsuite/tests/javascript/T23101.stdout
- + testsuite/tests/javascript/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -553,7 +553,7 @@ countArgs _                               = 0
 
 countValArgs :: SimplCont -> Int
 -- Count value arguments only
-countValArgs (ApplyToTy  { sc_cont = cont }) = 1 + countValArgs cont
+countValArgs (ApplyToTy  { sc_cont = cont }) = countValArgs cont
 countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont
 countValArgs (CastIt _ cont)                 = countValArgs cont
 countValArgs _                               = 0
@@ -1859,11 +1859,12 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr
                 -> SimplM (ArityType, OutExpr)
 -- See Note [Eta-expanding at let bindings]
 tryEtaExpandRhs env bind_cxt bndr rhs
-  | do_eta_expand           -- If the current manifest arity isn't enough
-                            --    (never true for join points)
-  , seEtaExpand env         -- and eta-expansion is on
-  , wantEtaExpansion rhs
-  = -- Do eta-expansion.
+  | seEtaExpand env         -- If Eta-expansion is on
+  , wantEtaExpansion rhs    -- and we'd like to eta-expand e
+  , do_eta_expand           -- and e's manifest arity is lower than
+                            --     what it could be
+                            --     (never true for join points)
+  =                         -- Do eta-expansion.
     assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $
        -- assert: this never happens for join points; see GHC.Core.Opt.Arity
        --         Note [Do not eta-expand join points]


=====================================
compiler/GHC/HsToCore/Foreign/JavaScript.hs
=====================================
@@ -639,7 +639,7 @@ jsResultWrapper result_ty
   | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do
 --    result_id <- newSysLocalDs boolTy
     ccall_uniq <- newUnique
-    let forceBool e = mkJsCall ccall_uniq (fsLit "$r = !(!$1)") [e] boolTy
+    let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy
     return
      (Just intPrimTy, \e -> forceBool e)
 


=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -115,8 +115,8 @@ genCommonCppDefs profiling = mconcat
 
   -- GHCJS.Prim.JSVal
   , if profiling
-      then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"
-      else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"
+      then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n"
+      else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n"
   ,  "#define JSVAL_VAL(x) ((x).d1)\n"
 
   -- GHCJS.Prim.JSException


=====================================
testsuite/tests/javascript/T23101.hs
=====================================
@@ -0,0 +1,22 @@
+
+foreign import javascript "(($1) => { return $1; })"
+  bool_id :: Bool -> Bool
+
+foreign import javascript "(($1) => { return !$1; })"
+  bool_not :: Bool -> Bool
+
+foreign import javascript "(($1) => { console.log($1); })"
+  bool_log :: Bool -> IO ()
+
+main :: IO ()
+main = do
+  bool_log True
+  bool_log False
+  bool_log (bool_id True)
+  bool_log (bool_id False)
+  bool_log (bool_not True)
+  bool_log (bool_not False)
+  print (bool_id True)
+  print (bool_id False)
+  print (bool_not True)
+  print (bool_not False)


=====================================
testsuite/tests/javascript/T23101.stdout
=====================================
@@ -0,0 +1,10 @@
+true
+false
+true
+false
+false
+true
+True
+False
+False
+True


=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -0,0 +1,4 @@
+# These are JavaScript-specific tests
+setTestOpts(when(not(js_arch()),skip))
+
+test('T23101', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/527137295fdfa11a05680f90cc4770f68acc4030...d55dacfef2e8384761367faa5893fe38e24822ef

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/527137295fdfa11a05680f90cc4770f68acc4030...d55dacfef2e8384761367faa5893fe38e24822ef
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/20230313/90c5b7ff/attachment-0001.html>