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