unboxedsums_unit_tests.hs

module Main where

import GHC.Types.Basic
import GHC
import GHC.Driver.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic hiding (assert)
import GHC.Types.RepType
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Types.Unique.Set
import GHC.Types.Unique

import qualified Control.Exception as E
import Control.Monad
import Data.Foldable
import System.Environment (getArgs)
import System.IO

assert :: Bool -> String -> SDoc -> IO ()
assert False tn msg = pprPanic tn msg
assert True  _  _   = return ()

main :: IO ()
main = do
    [libdir] <- getArgs
    runGhc (Just libdir) $ liftIO $ do
      -- need to initialize the monad to initialize static flags etc.
      sequence_ [ uniq_tests, layout_tests ]

-- Make sure sum datacon/tycon uniques are really uniq
uniq_tests :: IO ()
uniq_tests = do
    let tycons   = map sumTyCon [2 .. 20]
        datacons = [ sumDataCon alt arity | arity <- [ 2 .. 20 ]
                                          , alt   <- [ 1 .. arity ] ]

        us = mkUniqSet (map getUnique tycons)
               `unionUniqSets` mkUniqSet (map getUnique datacons)

    assert (sizeUniqSet us == length tycons + length datacons)
           "uniq_tests"
           (text "Sum cons/tycons have same uniques.")

layout_tests :: IO ()
layout_tests = sequence_
    [ layout1, layout2, layout3, layout4, layout5, enum_layout ]
  where
    assert_layout tn tys layout =
      let
        layout_ret = ubxSumRepType (map typePrimRep tys)
      in
        assert (toList layout_ret == layout)
               tn
               (text "Unexpected sum layout." $$
                text "Alts:           " <+> ppr tys $$
                text "Expected layout:" <+> ppr layout $$
                text "Actual layout:  " <+> ppr layout_ret)

    ubxtup = mkTupleTy Unboxed

    layout1 =
      assert_layout "layout1"
        [ ubxtup [ intTy, intPrimTy ]
        , ubxtup [ intPrimTy, intTy ] ]
        [ WordSlot, PtrLiftedSlot, WordSlot ]

    layout2 =
      assert_layout "layout2"
        [ ubxtup [ intTy ]
        , intTy ]
        [ WordSlot, PtrLiftedSlot ]

    layout3 =
      assert_layout "layout3"
        [ ubxtup [ intTy, intPrimTy, intTy, intPrimTy ]
        , ubxtup [ intPrimTy, intTy, intPrimTy, intTy ] ]
        [ WordSlot, PtrLiftedSlot, PtrLiftedSlot, WordSlot, WordSlot ]

    layout4 =
      assert_layout "layout4"
        [ ubxtup [ floatPrimTy, floatPrimTy ]
        , ubxtup [ intPrimTy, intPrimTy ] ]
        [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]

    layout5 =
      assert_layout "layout5"
        [ ubxtup [ intPrimTy, intPrimTy ]
        , ubxtup [ floatPrimTy, floatPrimTy ] ]
        [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]

    enum_layout =
      assert_layout "enum"
        (replicate 10 (ubxtup []))
        [ WordSlot ]