1{-# LANGUAGE TupleSections #-} 2 3-- Generates CmmSwitch.hs 4 5import qualified Data.Set as S 6import Data.Word 7import Data.List 8 9output :: Integer -> Integer 10output n = n`div`2 + 42 11 12def :: Integer 13def = 1337 14 15type Spec = (String, Bool, [Integer]) 16 17primtyp True = "Int#" 18primtyp False = "Word#" 19 20con True = "I#" 21con False = "W#" 22 23hash True = "#" 24hash False = "##" 25 26primLit s v = show v ++ hash s 27 28genSwitch :: Spec -> String 29genSwitch (name, signed, values) = unlines $ 30 [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ 31 [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ 32 [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) 33 | v <- values] ++ 34 [ name ++ " _ = " ++ primLit signed def ] 35 36genCheck :: Spec -> String 37genCheck (name, signed, values) = unlines $ 38 [ checkName name ++ " :: IO ()" 39 , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" 40 , " let r = " ++ con signed ++ " (" ++ name ++ " i)" 41 , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" 42 ] 43 where 44 f x | x `S.member` range = output x 45 | otherwise = def 46 range = S.fromList values 47 checkValues = S.toList $ S.fromList $ 48 [ v' | v <- values, v' <- [v-1,v,v+1], 49 if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] 50 pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] 51 52checkName :: String -> String 53checkName f = f ++ "_check" 54 55genMain :: [Spec] -> String 56genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] 57 58genMod :: [Spec] -> String 59genMod specs = unlines $ 60 "-- This file is generated from CmmSwitchGen!" : 61 "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : 62 "import Control.Monad (unless, forM_)" : 63 "import GHC.Exts" : 64 map genSwitch specs ++ 65 map genCheck specs ++ 66 [ genMain specs ] 67 68main = putStrLn $ 69 genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks 70 71 72signedChecks :: [(Bool, [Integer])] 73signedChecks = map (True,) 74 [ [1..10] 75 , [0..10] 76 , [1..3] 77 , [1..4] 78 , [1..5] 79 , [-1..10] 80 , [-10..10] 81 , [-20.. -10]++[0..10] 82 , [-20.. -10]++[1..10] 83 , [minS,0,maxS] 84 , [maxS-10 .. maxS] 85 , [minS..minS+10]++[maxS-10 .. maxS] 86 ] 87 88minU, maxU, minS, maxS :: Integer 89minU = 0 90maxU = fromIntegral (maxBound :: Word) 91minS = fromIntegral (minBound :: Int) 92maxS = fromIntegral (maxBound :: Int) 93 94 95unsignedChecks :: [(Bool, [Integer])] 96unsignedChecks = map (False,) 97 [ [0..10] 98 , [1..10] 99 , [0] 100 , [0..1] 101 , [0..2] 102 , [0..3] 103 , [0..4] 104 , [1] 105 , [1..2] 106 , [1..3] 107 , [1..4] 108 , [1..5] 109 , [minU,maxU] 110 , [maxU-10 .. maxU] 111 , [minU..minU+10]++[maxU-10 .. maxU] 112 ] 113 114names :: [String] 115names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] 116