Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC Commits: 638eef06 by Rodrigo Mesquita at 2026-04-01T15:19:15+01:00 test: Validate topoSort logic in createBCOs This test validates that the topological sorting and ordering of the unlifted constructors and lifted constructors in `createBCOs` is correct. See `Note [Tying the knot in createBCOs]` for why tying the knot for the created BCOs is slightly difficult and why the topological sorting is necessary. This test fails when `let topoSortedObjs = topSortObjs objs` is substituted by `let topoSortedObjs = zip [0..] objs`, thus witnessing the toposort logic is correct and necessary. The test calls the ghci `createBCOs` directly because it is currently impossible to construct in Source Haskell a situation where a top-level static unlifted constructor depends on another (we don't have top-level unlifted constructors except for nullary constructors like `Leaf :: (UTree :: UnliftedType)`). This is another test for fix for #25636 - - - - - 3 changed files: - + testsuite/tests/ghci/should_run/T25636f.hs - + testsuite/tests/ghci/should_run/T25636f.stdout - testsuite/tests/ghci/should_run/all.T Changes: ===================================== testsuite/tests/ghci/should_run/T25636f.hs ===================================== @@ -0,0 +1,160 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedDatatypes #-} + +module Main where + +import Prelude +import Control.Monad (unless) +import Data.Array.Unboxed (UArray, listArray) +import qualified Data.ByteString.Char8 as BS +import Data.Word (Word) +import GHC.Data.SmallArray (smallArrayFromList) +import GHC.Exts +import GHCi.CreateBCO (createBCOs) +import GHCi.InfoTable (mkConInfoTable) +import GHCi.RemoteTypes (HValue(..), HValueRef, RemotePtr, localRef, toRemotePtr) +import GHCi.ResolvedBCO + ( BCOByteArray + , ResolvedBCO(..) + , ResolvedBCOPtr(..) + , isLittleEndian + , mkBCOByteArray + ) +import qualified GHC.Exts.Heap as Heap + +type UTree :: UnliftedType +data UTree where + LeafA :: UTree + LeafB :: UTree + Bin :: UTree -> UTree -> UTree + +data Boxed where + RootBox :: UTree -> Boxed + PairBox :: UTree -> UTree -> Boxed + +main :: IO () +main = do + leafAInfo <- mkInfoTable 1 0 "LeafA" + leafBInfo <- mkInfoTable 2 0 "LeafB" + binInfo <- mkInfoTable 3 2 "Bin" + rootInfo <- mkInfoTable 1 1 "RootBox" + pairInfo <- mkInfoTable 2 2 "PairBox" + -- This test tests the topological sorting done to unlifted constructor + -- applications in `createBCOs` (call to `createUnliftedStaticCons`) + -- When the topological sort isn't done, this test fails with weird results. + refs <- createBCOs + [ rootBoxCon rootInfo 1 + , binCon binInfo 1 2 + , binCon binInfo 3 4 + , binCon binInfo 4 3 -- recall ResolvedUnliftedStaticConRef are indices into the unl-objs-only-array + , rootBoxCon rootInfo 0 + , leafCon leafAInfo + , leafCon leafBInfo + , pairBoxCon pairInfo 3 1 -- these are indices into unl-objs-array too (ResolvedUnliftedStaticConRef) + ] + actual <- mapM (\(unbx, ref) -> if unbx then extractUTree ref else extractBoxedRef ref) + -- test also that output order of references from createBCOs matches the + -- input order of Resolved objects + $ zip [False, True, True, True, False, True, True, False] refs + let expected = + ["RootBox (Bin LeafA LeafB)" + ,"Bin (Bin LeafA LeafB) (Bin LeafB LeafA)" + ,"Bin LeafA LeafB" + ,"Bin LeafB LeafA" + ,"RootBox (Bin (Bin LeafA LeafB) (Bin LeafB LeafA))" + ,"LeafA" + ,"LeafB" + ,"PairBox (LeafA) (Bin LeafA LeafB)"] + unless (actual == expected) $ + putStrLn "expected result of createBCOs differ from actual!" + print actual + where + leafCon leafInfo = + ResolvedStaticCon + { resolvedBCOIsLE = isLittleEndian + , resolvedStaticConInfoPtr = leafInfo + , resolvedStaticConArity = 0 + , resolvedStaticConLits = wordArray [] + , resolvedStaticConPtrs = smallArrayFromList [] + , resolvedStaticConIsUnlifted = True + } + + binCon binInfo left right = + ResolvedStaticCon + { resolvedBCOIsLE = isLittleEndian + , resolvedStaticConInfoPtr = binInfo + , resolvedStaticConArity = 2 + , resolvedStaticConLits = wordArray [] + , resolvedStaticConPtrs = + smallArrayFromList + [ ResolvedUnliftedStaticConRef left + , ResolvedUnliftedStaticConRef right + ] + , resolvedStaticConIsUnlifted = True + } + + rootBoxCon rootBoxInfo tree = + ResolvedStaticCon + { resolvedBCOIsLE = isLittleEndian + , resolvedStaticConInfoPtr = rootBoxInfo + , resolvedStaticConArity = 1 + , resolvedStaticConLits = wordArray [] + , resolvedStaticConPtrs = + smallArrayFromList [ResolvedUnliftedStaticConRef tree] + , resolvedStaticConIsUnlifted = False + } + + pairBoxCon pairBoxInfo left right = + ResolvedStaticCon + { resolvedBCOIsLE = isLittleEndian + , resolvedStaticConInfoPtr = pairBoxInfo + , resolvedStaticConArity = 2 + , resolvedStaticConLits = wordArray [] + , resolvedStaticConPtrs = + smallArrayFromList + [ ResolvedUnliftedStaticConRef left + , ResolvedUnliftedStaticConRef right + ] + , resolvedStaticConIsUnlifted = False + } + +mkInfoTable :: Int -> Int -> String -> IO (RemotePtr Heap.StgInfoTable) +mkInfoTable tag ptrs desc = + toRemotePtr <$> mkConInfoTable True ptrs 0 (tag - 1) tag (BS.pack desc) + +extractBoxedRef :: HValueRef -> IO String +extractBoxedRef ref = do + HValue hv <- localRef ref + pure $ case unsafeCoerce# hv of + boxed -> flattenBoxed boxed + +extractUTree :: HValueRef -> IO String +extractUTree ref = do + HValue hv <- localRef ref + pure $ case unsafeCoerce# hv of + utree -> flattenUTree utree + +flattenBoxed :: Boxed -> String +flattenBoxed = \case + RootBox tree -> "RootBox (" ++ flattenUTree tree ++ ")" + PairBox left right -> + "PairBox (" ++ flattenUTree left ++ ") (" ++ flattenUTree right ++ ")" + +flattenUTree :: UTree -> String +flattenUTree = \case + LeafA -> "LeafA" + LeafB -> "LeafB" + Bin left right -> "Bin " ++ par (flattenUTree left) ++ " " ++ par (flattenUTree right) + where + par s + | s == "LeafA" || s == "LeafB" = s + | otherwise = "(" ++ s ++ ")" + +wordArray :: [Word] -> BCOByteArray Word +wordArray ws = mkBCOByteArray (listArray (0, length ws - 1) ws) ===================================== testsuite/tests/ghci/should_run/T25636f.stdout ===================================== @@ -0,0 +1 @@ +["RootBox (Bin LeafA LeafB)","Bin (Bin LeafA LeafB) (Bin LeafB LeafA)","Bin LeafA LeafB","Bin LeafB LeafA","RootBox (Bin (Bin LeafA LeafB) (Bin LeafB LeafA))","LeafA","LeafB","PairBox (LeafA) (Bin LeafA LeafB)"] ===================================== testsuite/tests/ghci/should_run/all.T ===================================== @@ -98,3 +98,10 @@ test('T24115', just_ghci + [extra_run_opts("-e ':add T24115.hs'")], ghci_script, test('T10920', [only_ways(ghci_ways), extra_files(['LocalPrelude/Prelude.hs'])], ghci_script, ['T10920.script']) test('TopEnvIface', [only_ways(ghci_ways)], makefile_test, []) test('T25790', [only_ways(ghci_ways), extra_ways(["ghci-opt"])], ghci_script, ['T25790.script']) +test('T25636f', + just_ghci + [ + extra_hc_opts("-package ghci -package ghc-heap"), + when(arch('wasm32'), skip) + ], + compile_and_run, + ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/638eef0609d0f4a2cb9924b8667808a9... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/638eef0609d0f4a2cb9924b8667808a9... You're receiving this email because of your account on gitlab.haskell.org.