DataLayout.hs

{-# LANGUAGE OverloadedStrings #-}
module LLVM.Test.DataLayout where

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

import Control.Monad.Trans.Except

import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Map as Map

import LLVM.AST
import LLVM.AST.DataLayout
import LLVM.AST.AddrSpace
import LLVM.DataLayout

ddl = defaultDataLayout LittleEndian

mergeWithDefaultDL :: DataLayout -> DataLayout
mergeWithDefaultDL dl =
  dl
  { pointerLayouts = pointerLayouts dl <> pointerLayouts (defaultDataLayout LittleEndian)
  , typeLayouts = typeLayouts dl <> typeLayouts (defaultDataLayout LittleEndian)
  }

instance Arbitrary Endianness where
  arbitrary = elements [LittleEndian, BigEndian]

instance Arbitrary AddrSpace where
  arbitrary = AddrSpace <$> arbitrary

instance Arbitrary Mangling where
  arbitrary =
    elements [ELFMangling, MIPSMangling, MachOMangling, WindowsCOFFMangling]

instance Arbitrary AlignmentInfo where
  arbitrary = AlignmentInfo <$> arbitrary <*> arbitrary

instance Arbitrary AlignType where
  arbitrary = elements [IntegerAlign, VectorAlign, FloatAlign]

instance Arbitrary DataLayout where
  arbitrary =
    DataLayout
      <$> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary
      <*> arbitrary

tests = testGroup "DataLayout" $
  testProperty "roundtrip"
    (\dl -> pure (Just (mergeWithDefaultDL dl)) == parseDataLayout LittleEndian (dataLayoutToString dl))
  :
  [
  testCase name $ do
    let Right parsed = runExcept $ parseDataLayout LittleEndian strDl
    (dataLayoutToString astDl, parsed) @?= (strDl, Just astDl)
  | (name, astDl, strDl) <- [
    ("little-endian", ddl, "e"),
    ("big-endian", defaultDataLayout BigEndian, "E"),
    ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "e-n8:32"),
    (
     "no pref",
     ddl {
       pointerLayouts = 
         Map.singleton
         (AddrSpace 0) 
         (
          8,
          AlignmentInfo 64 64
         )
     },
     "e-p:8:64"
    ), (
     "pref",
     ddl {
       pointerLayouts = 
         Map.insert (AddrSpace 1) (8, AlignmentInfo 32 64) (pointerLayouts ddl)
     },
     "e-p1:8:32:64"
    ), (
     "def",
     ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 64) },
     "e"
    ), (
     "big",
     ddl {
       endianness = LittleEndian,
       mangling = Just ELFMangling,
       stackAlignment = Just 128,
       pointerLayouts = Map.fromList [
         (AddrSpace 0, (8, AlignmentInfo 8 16))
        ],
       typeLayouts = Map.fromList [
         ((IntegerAlign, 1), AlignmentInfo 8 256),
         ((IntegerAlign, 8), AlignmentInfo 8 256),
         ((IntegerAlign, 16), AlignmentInfo 16 256),
         ((IntegerAlign, 32), AlignmentInfo 32 256),
         ((IntegerAlign, 64), AlignmentInfo 64 256),
         ((VectorAlign, 64), AlignmentInfo 64 256),
         ((VectorAlign, 128), AlignmentInfo 128 256),
         ((FloatAlign, 32), AlignmentInfo 32 256),
         ((FloatAlign, 64), AlignmentInfo 64 256),
         ((FloatAlign, 80), AlignmentInfo 128 256)
        ] `Map.union` typeLayouts ddl, 
       aggregateLayout = AlignmentInfo 0 256,
       nativeSizes = Just (Set.fromList [8,16,32,64])
     },
     "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-v64:64:256-v128:128:256-f32:32:256-f64:64:256-f80:128:256-a:0:256-n8:16:32:64-S128"
    )
   ]
 ]