Update Trac ticket URLs to point to GitLab
[ghc.git] / testsuite / tests / unboxedsums / unboxedsums_unit_tests.hs
1 module Main where
2
3 import BasicTypes
4 import GHC
5 import GhcMonad
6 import Outputable
7 import RepType
8 import TysPrim
9 import TysWiredIn
10 import UniqSet
11 import Unique
12
13 import qualified Control.Exception as E
14 import Control.Monad
15 import System.Environment (getArgs)
16 import System.IO
17
18 assert :: Bool -> String -> SDoc -> IO ()
19 assert False tn msg = pprPanic tn msg
20 assert True _ _ = return ()
21
22 main :: IO ()
23 main = do
24 [libdir] <- getArgs
25 runGhc (Just libdir) $ liftIO $ do
26 -- need to initialize the monad to initialize static flags etc.
27 sequence_ [ uniq_tests, layout_tests ]
28
29 -- Make sure sum datacon/tycon uniques are really uniq
30 uniq_tests :: IO ()
31 uniq_tests = do
32 let tycons = map sumTyCon [2 .. 20]
33 datacons = [ sumDataCon alt arity | arity <- [ 2 .. 20 ]
34 , alt <- [ 1 .. arity ] ]
35
36 us = mkUniqSet (map getUnique tycons)
37 `unionUniqSets` mkUniqSet (map getUnique datacons)
38
39 assert (sizeUniqSet us == length tycons + length datacons)
40 "uniq_tests"
41 (text "Sum cons/tycons have same uniques.")
42
43 layout_tests :: IO ()
44 layout_tests = sequence_
45 [ layout1, layout2, layout3, layout4, layout5, enum_layout ]
46 where
47 assert_layout tn tys layout =
48 let
49 layout_ret = ubxSumRepType (map typePrimRep tys)
50 in
51 assert (layout_ret == layout)
52 tn
53 (text "Unexpected sum layout." $$
54 text "Alts: " <+> ppr tys $$
55 text "Expected layout:" <+> ppr layout $$
56 text "Actual layout: " <+> ppr layout_ret)
57
58 ubxtup = mkTupleTy Unboxed
59
60 layout1 =
61 assert_layout "layout1"
62 [ ubxtup [ intTy, intPrimTy ]
63 , ubxtup [ intPrimTy, intTy ] ]
64 [ WordSlot, PtrSlot, WordSlot ]
65
66 layout2 =
67 assert_layout "layout2"
68 [ ubxtup [ intTy ]
69 , intTy ]
70 [ WordSlot, PtrSlot ]
71
72 layout3 =
73 assert_layout "layout3"
74 [ ubxtup [ intTy, intPrimTy, intTy, intPrimTy ]
75 , ubxtup [ intPrimTy, intTy, intPrimTy, intTy ] ]
76 [ WordSlot, PtrSlot, PtrSlot, WordSlot, WordSlot ]
77
78 layout4 =
79 assert_layout "layout4"
80 [ ubxtup [ floatPrimTy, floatPrimTy ]
81 , ubxtup [ intPrimTy, intPrimTy ] ]
82 [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]
83
84 layout5 =
85 assert_layout "layout5"
86 [ ubxtup [ intPrimTy, intPrimTy ]
87 , ubxtup [ floatPrimTy, floatPrimTy ] ]
88 [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]
89
90 enum_layout =
91 assert_layout "enum"
92 (replicate 10 (ubxtup []))
93 [ WordSlot ]