GitLab

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

Commits:

e2d57026

by Luite Stegeman at 2026-09-15T20:13:54-04:00

JS: fix selector thunk handling

fix a bug where entering a selector thunk could lead to a crash
if the selected field was still a thunk.

fixes #27788

6 changed files:

+ changelog.d/T27788-js-selector
compiler/GHC/StgToJS/Apply.hs
compiler/GHC/StgToJS/Symbols.hs
+ testsuite/tests/javascript/T27788.hs
+ testsuite/tests/javascript/T27788.stdout
testsuite/tests/javascript/all.T

Changes:

changelog.d/T27788-js-selector

 +section: js-backend
 +synopsis: Fix a bug in the JavaScript backend: Entering a selector thunk whose selected field was an unevaluated thunk could duplicate work or crash the program with a type error.
 +issues: #27788
 +mrs: !16681

compiler/GHC/StgToJS/Apply.hs

@@ -1036,7 +1036,12 @@ updates s = do
                            [ si' |= ss' .! i
                            , sir' |= (closureField2 si') `ApplExpr` [r1]
                            , ifS (app "typeof" [sir'] .===. jTyObject)
 -                            (copyClosure DontCopyCC si' sir')
 +                            (ifS (isThunk sir' .||. isBlackhole sir')
 +                              (mconcat [ closureInfo   si' |= hdUpdThunkEntry
 +                                       , closureField1 si' |= sir'
 +                                       , closureField2 si' |= null_
 +                                       ])
 +                              (copyClosure DontCopyCC si' sir'))
                              (assignClosure si' $ unbox_closure sir')
                            , postIncrS i
+                           ]
@@ -1066,7 +1071,8 @@ updates s = do
                                 , -- update selectors
                                   jwhenS ((app typeof [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
                                   ((ss |= closureMeta updatee .^ "sel")
 -                                  <> upd_loop)
 +                                  <> upd_loop
 +                                  <> (closureMeta updatee .^ "sel" |= null_))
                                 , -- overwrite the object
                                   ifS (app typeof [r1] .===. jTyObject)
                                   (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureInfo r1) .^ "n"))

compiler/GHC/StgToJS/Symbols.hs

@@ -375,6 +375,9 @@ hdCAFsResetStr       = name "h$CAFsReset"
  hdUpdThunkEntryStr :: Ident
  hdUpdThunkEntryStr = name "h$upd_thunk_e"
 +hdUpdThunkEntry :: JStgExpr
 +hdUpdThunkEntry = global (identFS hdUpdThunkEntryStr)
++
  hdAp3EntryStr :: Ident
  hdAp3EntryStr = name "h$ap3_e"

testsuite/tests/javascript/T27788.hs

 +module Main where
++
 +import Control.Exception (evaluate)
 +import System.Environment (getArgs)
++
 +{-# NOINLINE mkInner #-}
 +mkInner :: Int -> (Int, Int)
 +mkInner n = (n + 1, n + 2)
++
 +{-# NOINLINE mkOuter #-}
 +mkOuter :: (Int, Int) -> Int -> ((Int, Int), Int)
 +mkOuter a n = (a, n)
++
 +main :: IO ()
 +main = do
 +  n <- length <$> getArgs
 +  let inner = mkInner n
 +      outer = mkOuter inner n
 +      (inner', _) = outer
 +      (p, _) = inner
 +  _ <- evaluate inner'
 +  print (fst inner')
 +  print (fst inner)
 +  print p
 +  print (snd outer)

testsuite/tests/javascript/T27788.stdout

 +1
 +1
 +1
 +0

testsuite/tests/javascript/all.T

@@ -28,3 +28,5 @@ test('T24744', normal, makefile_test, ['T24744'])
  test('T25633', normal, compile_and_run, [''])
  test('T24886', normal, compile, [''])
++
 +test('T27788', normal, compile_and_run, ['-O0'])