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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
module Syntax where
import Data.List (nub)
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
------------------------------------------------------------------
-- info for all primops; the totality of the info in primops.txt(.pp)
data Info
= Info [Option] [Entry] -- defaults, primops
deriving Show
-- info for one primop
data Entry
= PrimOpSpec { cons :: String, -- PrimOp name
name :: String, -- name in prog text
ty :: Ty, -- type
cat :: Category, -- category
desc :: String, -- description
opts :: [Option] } -- default overrides
| PrimVecOpSpec { cons :: String, -- PrimOp name
name :: String, -- name in prog text
prefix :: String, -- prefix for generated names
veclen :: Int, -- vector length
elemrep :: String, -- vector ElemRep
ty :: Ty, -- type
cat :: Category, -- category
desc :: String, -- description
opts :: [Option] } -- default overrides
| PseudoOpSpec { name :: String, -- name in prog text
ty :: Ty, -- type
desc :: String, -- description
opts :: [Option] } -- default overrides
| PrimTypeSpec { ty :: Ty, -- name in prog text
desc :: String, -- description
opts :: [Option] } -- default overrides
| PrimVecTypeSpec { ty :: Ty, -- name in prog text
prefix :: String, -- prefix for generated names
veclen :: Int, -- vector length
elemrep :: String, -- vector ElemRep
desc :: String, -- description
opts :: [Option] } -- default overrides
| Section { title :: String, -- section title
desc :: String } -- description
deriving Show
is_primop :: Entry -> Bool
is_primop (PrimOpSpec _ _ _ _ _ _) = True
is_primop _ = False
is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False
-- a binding of property to value
data Option
= OptionFalse String -- name = False
| OptionTrue String -- name = True
| OptionString String String -- name = { ... unparsed stuff ... }
| OptionInteger String Int -- name = <int>
| OptionVector [(String,String,Int)] -- name = [(,...),...]
| OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing
deriving Show
-- categorises primops
data Category
= Compare | GenPrimOp
deriving Show
-- types
data Ty
= TyF Ty Ty
| TyC Ty Ty -- We only allow one constraint, keeps the grammar simpler
| TyApp TyCon [Ty]
| TyVar TyVar
| TyUTup [Ty] -- unboxed tuples; just a TyCon really,
-- but convenient like this
deriving (Eq,Show)
type TyVar = String
type TyVarBinder = String
data TyCon = TyCon String
| SCALAR
| VECTOR
| VECTUPLE
| VecTyCon String String
deriving (Eq, Ord)
instance Show TyCon where
show (TyCon tc) = tc
show SCALAR = "SCALAR"
show VECTOR = "VECTOR"
show VECTUPLE = "VECTUPLE"
show (VecTyCon tc _) = tc
-- Follow definitions of Fixity and FixityDirection in GHC
-- The SourceText exists so that it matches the SourceText field in
-- BasicTypes.Fixity
data Fixity = Fixity SourceText Int FixityDirection
deriving (Eq, Show)
data FixityDirection = InfixN | InfixL | InfixR
deriving (Eq, Show)
data SourceText = SourceText String
| NoSourceText
deriving (Eq,Show)
------------------------------------------------------------------
-- Sanity checking -----------------------------------------------
------------------------------------------------------------------
{- Do some simple sanity checks:
* all the default field names are unique
* for each PrimOpSpec, all override field names are unique
* for each PrimOpSpec, all overridden field names
have a corresponding default value
* that primop types correspond in certain ways to the
Category: eg if Comparison, the type must be of the form
T -> T -> Bool.
Dies with "error" if there's a problem, else returns ().
-}
myseqAll :: [()] -> a -> a
myseqAll (():ys) x = myseqAll ys x
myseqAll [] x = x
sanityTop :: Info -> ()
sanityTop (Info defs entries)
= let opt_names = map get_attrib_name defs
primops = filter is_primop entries
in
if length opt_names /= length (nub opt_names)
then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
else myseqAll (map (sanityPrimOp opt_names) primops) ()
sanityPrimOp :: [String] -> Entry -> ()
sanityPrimOp def_names p
= let p_names = map get_attrib_name (opts p)
p_names_ok
= length p_names == length (nub p_names)
&& all (`elem` def_names) p_names
ty_ok = sane_ty (cat p) (ty p)
in
if not p_names_ok
then error ("attribute names are non-unique or have no default in\n" ++
"info for primop " ++ cons p ++ "\n")
else
if not ty_ok
then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
" category " ++ show (cat p) ++ "\n")
else ()
sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td))
| t1 == t2 && td == TyApp (TyCon "Int#") [] = True
sane_ty GenPrimOp _
= True
sane_ty _ _
= False
get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm) = nm
get_attrib_name (OptionString nm _) = nm
get_attrib_name (OptionInteger nm _) = nm
get_attrib_name (OptionVector _) = "vector"
get_attrib_name (OptionFixity _) = "fixity"
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as)
= if get_attrib_name a == nm then Just a else lookup_attrib nm as
is_vector :: Entry -> Bool
is_vector i = case lookup_attrib "vector" (opts i) of
Nothing -> False
_ -> True
|
