Rodrigo Mesquita pushed to branch wip/romes/25636 at Glasgow Haskell Compiler / GHC

Commits:

3 changed files:

Changes:

  • testsuite/tests/ghci/should_run/T25636f.hs
    1 
    +{-# LANGUAGE DataKinds #-}
    2 
    +{-# LANGUAGE GADTs #-}
    3 
    +{-# LANGUAGE LambdaCase #-}
    4 
    +{-# LANGUAGE MagicHash #-}
    5 
    +{-# LANGUAGE KindSignatures #-}
    6 
    +{-# LANGUAGE StandaloneKindSignatures #-}
    7 
    +{-# LANGUAGE UnboxedTuples #-}
    8 
    +{-# LANGUAGE UnliftedDatatypes #-}
    9 
    +
    10 
    +module Main where
    11 
    +
    12 
    +import Prelude
    13 
    +import Control.Monad (unless)
    14 
    +import Data.Array.Unboxed (UArray, listArray)
    15 
    +import qualified Data.ByteString.Char8 as BS
    16 
    +import Data.Word (Word)
    17 
    +import GHC.Data.SmallArray (smallArrayFromList)
    18 
    +import GHC.Exts
    19 
    +import GHCi.CreateBCO (createBCOs)
    20 
    +import GHCi.InfoTable (mkConInfoTable)
    21 
    +import GHCi.RemoteTypes (HValue(..), HValueRef, RemotePtr, localRef, toRemotePtr)
    22 
    +import GHCi.ResolvedBCO
    23 
    +  ( BCOByteArray
    24 
    +  , ResolvedBCO(..)
    25 
    +  , ResolvedBCOPtr(..)
    26 
    +  , isLittleEndian
    27 
    +  , mkBCOByteArray
    28 
    +  )
    29 
    +import qualified GHC.Exts.Heap as Heap
    30 
    +
    31 
    +type UTree :: UnliftedType
    32 
    +data UTree where
    33 
    +  LeafA :: UTree
    34 
    +  LeafB :: UTree
    35 
    +  Bin :: UTree -> UTree -> UTree
    36 
    +
    37 
    +data Boxed where
    38 
    +  RootBox :: UTree -> Boxed
    39 
    +  PairBox :: UTree -> UTree -> Boxed
    40 
    +
    41 
    +main :: IO ()
    42 
    +main = do
    43 
    +  leafAInfo <- mkInfoTable 1 0 "LeafA"
    44 
    +  leafBInfo <- mkInfoTable 2 0 "LeafB"
    45 
    +  binInfo   <- mkInfoTable 3 2 "Bin"
    46 
    +  rootInfo  <- mkInfoTable 1 1 "RootBox"
    47 
    +  pairInfo  <- mkInfoTable 2 2 "PairBox"
    48 
    +  -- This test tests the topological sorting done to unlifted constructor
    49 
    +  -- applications in `createBCOs` (call to `createUnliftedStaticCons`)
    50 
    +  -- When the topological sort isn't done, this test fails with weird results.
    51 
    +  refs <- createBCOs
    52 
    +    [ rootBoxCon rootInfo 1
    53 
    +    , binCon binInfo 1 2
    54 
    +    , binCon binInfo 3 4
    55 
    +    , binCon binInfo 4 3 -- recall ResolvedUnliftedStaticConRef are indices into the unl-objs-only-array
    56 
    +    , rootBoxCon rootInfo 0
    57 
    +    , leafCon leafAInfo
    58 
    +    , leafCon leafBInfo
    59 
    +    , pairBoxCon pairInfo 3 1 -- these are indices into unl-objs-array too (ResolvedUnliftedStaticConRef)
    60 
    +    ]
    61 
    +  actual <- mapM (\(unbx, ref) -> if unbx then extractUTree ref else extractBoxedRef ref)
    62 
    +    -- test also that output order of references from createBCOs matches the
    63 
    +    -- input order of Resolved objects
    64 
    +    $ zip [False, True, True, True, False, True, True, False] refs
    65 
    +  let expected =
    66 
    +        ["RootBox (Bin LeafA LeafB)"
    67 
    +        ,"Bin (Bin LeafA LeafB) (Bin LeafB LeafA)"
    68 
    +        ,"Bin LeafA LeafB"
    69 
    +        ,"Bin LeafB LeafA"
    70 
    +        ,"RootBox (Bin (Bin LeafA LeafB) (Bin LeafB LeafA))"
    71 
    +        ,"LeafA"
    72 
    +        ,"LeafB"
    73 
    +        ,"PairBox (LeafA) (Bin LeafA LeafB)"]
    74 
    +  unless (actual == expected) $
    75 
    +    putStrLn "expected result of createBCOs differ from actual!"
    76 
    +  print actual
    77 
    +  where
    78 
    +    leafCon leafInfo =
    79 
    +      ResolvedStaticCon
    80 
    +        { resolvedBCOIsLE = isLittleEndian
    81 
    +        , resolvedStaticConInfoPtr = leafInfo
    82 
    +        , resolvedStaticConArity = 0
    83 
    +        , resolvedStaticConLits = wordArray []
    84 
    +        , resolvedStaticConPtrs = smallArrayFromList []
    85 
    +        , resolvedStaticConIsUnlifted = True
    86 
    +        }
    87 
    +
    88 
    +    binCon binInfo left right =
    89 
    +      ResolvedStaticCon
    90 
    +        { resolvedBCOIsLE = isLittleEndian
    91 
    +        , resolvedStaticConInfoPtr = binInfo
    92 
    +        , resolvedStaticConArity = 2
    93 
    +        , resolvedStaticConLits = wordArray []
    94 
    +        , resolvedStaticConPtrs =
    95 
    +            smallArrayFromList
    96 
    +              [ ResolvedUnliftedStaticConRef left
    97 
    +              , ResolvedUnliftedStaticConRef right
    98 
    +              ]
    99 
    +        , resolvedStaticConIsUnlifted = True
    100 
    +        }
    101 
    +
    102 
    +    rootBoxCon rootBoxInfo tree =
    103 
    +      ResolvedStaticCon
    104 
    +        { resolvedBCOIsLE = isLittleEndian
    105 
    +        , resolvedStaticConInfoPtr = rootBoxInfo
    106 
    +        , resolvedStaticConArity = 1
    107 
    +        , resolvedStaticConLits = wordArray []
    108 
    +        , resolvedStaticConPtrs =
    109 
    +            smallArrayFromList [ResolvedUnliftedStaticConRef tree]
    110 
    +        , resolvedStaticConIsUnlifted = False
    111 
    +        }
    112 
    +
    113 
    +    pairBoxCon pairBoxInfo left right =
    114 
    +      ResolvedStaticCon
    115 
    +        { resolvedBCOIsLE = isLittleEndian
    116 
    +        , resolvedStaticConInfoPtr = pairBoxInfo
    117 
    +        , resolvedStaticConArity = 2
    118 
    +        , resolvedStaticConLits = wordArray []
    119 
    +        , resolvedStaticConPtrs =
    120 
    +            smallArrayFromList
    121 
    +              [ ResolvedUnliftedStaticConRef left
    122 
    +              , ResolvedUnliftedStaticConRef right
    123 
    +              ]
    124 
    +        , resolvedStaticConIsUnlifted = False
    125 
    +        }
    126 
    +
    127 
    +mkInfoTable :: Int -> Int -> String -> IO (RemotePtr Heap.StgInfoTable)
    128 
    +mkInfoTable tag ptrs desc =
    129 
    +  toRemotePtr <$> mkConInfoTable True ptrs 0 (tag - 1) tag (BS.pack desc)
    130 
    +
    131 
    +extractBoxedRef :: HValueRef -> IO String
    132 
    +extractBoxedRef ref = do
    133 
    +  HValue hv <- localRef ref
    134 
    +  pure $ case unsafeCoerce# hv of
    135 
    +    boxed -> flattenBoxed boxed
    136 
    +
    137 
    +extractUTree :: HValueRef -> IO String
    138 
    +extractUTree ref = do
    139 
    +  HValue hv <- localRef ref
    140 
    +  pure $ case unsafeCoerce# hv of
    141 
    +    utree -> flattenUTree utree
    142 
    +
    143 
    +flattenBoxed :: Boxed -> String
    144 
    +flattenBoxed = \case
    145 
    +  RootBox tree -> "RootBox (" ++ flattenUTree tree ++ ")"
    146 
    +  PairBox left right ->
    147 
    +    "PairBox (" ++ flattenUTree left ++ ") (" ++ flattenUTree right ++ ")"
    148 
    +
    149 
    +flattenUTree :: UTree -> String
    150 
    +flattenUTree = \case
    151 
    +  LeafA -> "LeafA"
    152 
    +  LeafB -> "LeafB"
    153 
    +  Bin left right -> "Bin " ++ par (flattenUTree left) ++ " " ++ par (flattenUTree right)
    154 
    +  where
    155 
    +    par s
    156 
    +      | s == "LeafA" || s == "LeafB" = s
    157 
    +      | otherwise = "(" ++ s ++ ")"
    158 
    +
    159 
    +wordArray :: [Word] -> BCOByteArray Word
    160 
    +wordArray ws = mkBCOByteArray (listArray (0, length ws - 1) ws)

  • testsuite/tests/ghci/should_run/T25636f.stdout
    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,
    98 98 
     test('T10920', [only_ways(ghci_ways), extra_files(['LocalPrelude/Prelude.hs'])], ghci_script, ['T10920.script'])
    99 99 
     test('TopEnvIface', [only_ways(ghci_ways)], makefile_test, [])
    100 100 
     test('T25790', [only_ways(ghci_ways), extra_ways(["ghci-opt"])], ghci_script, ['T25790.script'])
    101 
    +test('T25636f',
    102 
    +     just_ghci + [
    103 
    +      extra_hc_opts("-package ghci -package ghc-heap"),
    104 
    +      when(arch('wasm32'), skip)
    105 
    +     ],
    106 
    +     compile_and_run,
    107 
    +     [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help