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