2 ------------------------------------------------------------------
3 -- A primop-table mangling program --
4 ------------------------------------------------------------------
12 import System ( getArgs )
13 import Maybe ( catMaybes )
15 main = getArgs >>= \args ->
16 if length args /= 1 || head args `notElem` known_args
17 then error ("usage: genprimopcode command < primops.txt > ...\n"
18 ++ " where command is one of\n"
19 ++ unlines (map (" "++) known_args)
23 let pres = parse pTop "" s
25 Left err -> do putStr "parse error at "
28 -> myseq (sanityTop p_o_specs) (
32 -> putStr (gen_data_decl p_o_specs)
35 -> putStr (gen_switch_from_attribs
37 "primOpHasSideEffects" p_o_specs)
40 -> putStr (gen_switch_from_attribs
42 "primOpOutOfLine" p_o_specs)
45 -> putStr (gen_switch_from_attribs
47 "commutableOp" p_o_specs)
50 -> putStr (gen_switch_from_attribs
52 "primOpNeedsWrapper" p_o_specs)
55 -> putStr (gen_switch_from_attribs
57 "primOpCanFail" p_o_specs)
60 -> putStr (gen_switch_from_attribs
62 "primOpStrictness" p_o_specs)
65 -> putStr (gen_switch_from_attribs
67 "primOpUsg" p_o_specs)
69 "--primop-primop-info"
70 -> putStr (gen_primop_info p_o_specs)
73 -> putStr (gen_primop_tag p_o_specs)
76 -> putStr (gen_primop_list p_o_specs)
78 "--make-haskell-wrappers"
79 -> putStr (gen_wrappers p_o_specs)
82 -> putStr (gen_latex_table p_o_specs)
95 "--primop-primop-info",
98 "--make-haskell-wrappers",
102 ------------------------------------------------------------------
103 -- Code generators -----------------------------------------------
104 ------------------------------------------------------------------
106 gen_latex_table (Info defaults pos)
107 = "\\begin{tabular}{|l|l|}\n"
108 ++ "\\hline\nName &\t Type\\\\\n\\hline\n"
109 ++ (concat (map f pos))
112 f spec = "@" ++ (encode (name spec)) ++ "@ &\t@" ++ (pty (ty spec)) ++ "@\\\\\n"
114 pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
116 pbty (TyApp tc ts) = (encode tc) ++ (concat (map (' ':) (map paty ts)))
117 pbty (TyUTup ts) = (mkUtupnm (length ts)) ++ (concat (map (' ':) (map paty ts)))
119 paty (TyVar tv) = encode tv
120 paty t = "(" ++ pty t ++ ")"
121 mkUtupnm 1 = "ZL#z32U#ZR"
122 mkUtupnm n = "Z" ++ (show (n-1)) ++ "U"
124 gen_wrappers (Info defaults pos)
125 = "module PrelPrimopWrappers where\n"
126 ++ "import qualified PrelGHC\n"
127 ++ unlines (map f (filter (not.dodgy) pos))
129 f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
130 src_name = wrap (name spec)
131 in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
132 src_name ++ " " ++ unwords args
133 ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
134 wrap nm | isLower (head nm) = nm
135 | otherwise = "(" ++ nm ++ ")"
139 [-- C code generator can't handle these
142 -- not interested in parallel support
143 "par#", "parGlobal#", "parLocal#", "parAt#",
144 "parAtAbs#", "parAtRel#", "parAtForNow#"
148 gen_primop_list (Info defaults pos)
150 [ " [" ++ cons (head pos) ]
152 map (\pi -> " , " ++ cons pi) (tail pos)
157 gen_primop_tag (Info defaults pos)
158 = unlines (zipWith f pos [1..])
160 f i n = "tagOf_PrimOp " ++ cons i
161 ++ " = _ILIT(" ++ show n ++ ") :: FastInt"
163 gen_data_decl (Info defaults pos)
164 = let conss = map cons pos
165 in "data PrimOp\n = " ++ head conss ++ "\n"
166 ++ unlines (map (" | "++) (tail conss))
168 gen_switch_from_attribs :: String -> String -> Info -> String
169 gen_switch_from_attribs attrib_name fn_name (Info defaults pos)
170 = let defv = lookup_attrib attrib_name defaults
171 alts = catMaybes (map mkAlt pos)
173 getAltRhs (OptionFalse _) = "False"
174 getAltRhs (OptionTrue _) = "True"
175 getAltRhs (OptionString _ s) = s
178 = case lookup_attrib attrib_name (opts po) of
180 Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
182 lookup_attrib nm [] = Nothing
183 lookup_attrib nm (a:as)
184 = if get_attrib_name a == nm then Just a else lookup_attrib nm as
187 Nothing -> error ("gen_switch_from: " ++ attrib_name)
190 ++ fn_name ++ " other = " ++ getAltRhs xx ++ "\n"
192 ------------------------------------------------------------------
193 -- Create PrimOpInfo text from PrimOpSpecs -----------------------
194 ------------------------------------------------------------------
197 gen_primop_info (Info defaults pos)
198 = unlines (map mkPOItext pos)
200 mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i
203 = "primOpInfo " ++ cons i ++ " = "
210 -> "mkCompare " ++ sl_name i ++ ppType t1
214 -> "mkMonadic " ++ sl_name i ++ ppType t1
218 -> "mkDyadic " ++ sl_name i ++ ppType t1
220 -> let (argTys, resTy) = flatTys (ty i)
221 tvs = nub (tvsIn (ty i))
223 "mkGenPrimOp " ++ sl_name i ++ " "
224 ++ listify (map ppTyVar tvs) ++ " "
225 ++ listify (map ppType argTys) ++ " "
226 ++ "(" ++ ppType resTy ++ ")"
228 sl_name i = "SLIT(\"" ++ name i ++ "\") "
230 ppTyVar "a" = "alphaTyVar"
231 ppTyVar "b" = "betaTyVar"
232 ppTyVar "c" = "gammaTyVar"
233 ppTyVar "s" = "deltaTyVar"
234 ppTyVar "o" = "openAlphaTyVar"
237 ppType (TyApp "Bool" []) = "boolTy"
239 ppType (TyApp "Int#" []) = "intPrimTy"
240 ppType (TyApp "Int64#" []) = "int64PrimTy"
241 ppType (TyApp "Char#" []) = "charPrimTy"
242 ppType (TyApp "Word#" []) = "wordPrimTy"
243 ppType (TyApp "Word64#" []) = "word64PrimTy"
244 ppType (TyApp "Addr#" []) = "addrPrimTy"
245 ppType (TyApp "Float#" []) = "floatPrimTy"
246 ppType (TyApp "Double#" []) = "doublePrimTy"
247 ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy"
248 ppType (TyApp "RealWorld" []) = "realWorldTy"
249 ppType (TyApp "ThreadId#" []) = "threadIdPrimTy"
250 ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy"
251 ppType (TyApp "BCO#" []) = "bcoPrimTy"
252 ppType (TyApp "Unit" []) = "unitTy" -- dodgy
255 ppType (TyVar "a") = "alphaTy"
256 ppType (TyVar "b") = "betaTy"
257 ppType (TyVar "c") = "gammaTy"
258 ppType (TyVar "s") = "deltaTy"
259 ppType (TyVar "o") = "openAlphaTy"
260 ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x
261 ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x
263 ppType (TyApp "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x
266 ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy "
269 ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x
272 ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x
273 ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x
274 ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x
276 ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x
278 ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ show (length ts)
280 ++ listify (map ppType ts) ++ ")"
282 ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
285 = error ("ppType: can't handle: " ++ show other ++ "\n")
287 listify :: [String] -> String
288 listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"
290 flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
291 flatTys other = ([],other)
293 tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2
294 tvsIn (TyApp tc tys) = concatMap tvsIn tys
295 tvsIn (TyVar tv) = [tv]
296 tvsIn (TyUTup tys) = concatMap tvsIn tys
298 arity = length . fst . flatTys
301 ------------------------------------------------------------------
302 -- Abstract syntax -----------------------------------------------
303 ------------------------------------------------------------------
305 -- info for all primops; the totality of the info in primops.txt
307 = Info [Option] [PrimOpSpec] -- defaults, primops
310 -- info for one primop
312 = PrimOpSpec { cons :: String, -- PrimOp name
313 name :: String, -- name in prog text
315 cat :: Category, -- category
316 opts :: [Option] } -- default overrides
319 -- a binding of property to value
321 = OptionFalse String -- name = False
322 | OptionTrue String -- name = True
323 | OptionString String String -- name = { ... unparsed stuff ... }
326 -- categorises primops
328 = Dyadic | Monadic | Compare | GenPrimOp
336 | TyUTup [Ty] -- unboxed tuples; just a TyCon really,
337 -- but convenient like this
344 ------------------------------------------------------------------
345 -- Sanity checking -----------------------------------------------
346 ------------------------------------------------------------------
348 {- Do some simple sanity checks:
349 * all the default field names are unique
350 * for each PrimOpSpec, all override field names are unique
351 * for each PrimOpSpec, all overriden field names
352 have a corresponding default value
353 * that primop types correspond in certain ways to the
354 Category: eg if Comparison, the type must be of the form
356 Dies with "error" if there's a problem, else returns ().
359 myseqAll (():ys) x = myseqAll ys x
362 sanityTop :: Info -> ()
363 sanityTop (Info defs primops)
364 = let opt_names = map get_attrib_name defs
366 if length opt_names /= length (nub opt_names)
367 then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
368 else myseqAll (map (sanityPrimOp opt_names) primops) ()
370 sanityPrimOp def_names p
371 = let p_names = map get_attrib_name (opts p)
373 = length p_names == length (nub p_names)
374 && all (`elem` def_names) p_names
375 ty_ok = sane_ty (cat p) (ty p)
378 then error ("attribute names are non-unique or have no default in\n" ++
379 "info for primop " ++ cons p ++ "\n")
382 then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
383 " category " ++ show (cat p) ++ "\n")
386 sane_ty Compare (TyF t1 (TyF t2 td))
387 | t1 == t2 && td == TyApp "Bool" [] = True
388 sane_ty Monadic (TyF t1 td)
390 sane_ty Dyadic (TyF t1 (TyF t2 td))
391 | t1 == t2 && t2 == t2 = True
392 sane_ty GenPrimOp any_old_thing
397 get_attrib_name (OptionFalse nm) = nm
398 get_attrib_name (OptionTrue nm) = nm
399 get_attrib_name (OptionString nm _) = nm
401 ------------------------------------------------------------------
402 -- The parser ----------------------------------------------------
403 ------------------------------------------------------------------
405 -- Due to lack of proper lexing facilities, a hack to zap any
408 pTop = then4 (\_ ds ss _ -> Info ds ss)
409 pCommentAndWhitespace pDefaults (many pPrimOpSpec)
410 (lit "thats_all_folks")
412 pDefaults :: Parser [Option]
413 pDefaults = then2 sel22 (lit "defaults") (many pOption)
415 pOption :: Parser Option
418 then3 (\nm eq ff -> OptionFalse nm) pName (lit "=") (lit "False"),
419 then3 (\nm eq tt -> OptionTrue nm) pName (lit "=") (lit "True"),
420 then3 (\nm eq zz -> OptionString nm zz)
421 pName (lit "=") pStuffBetweenBraces
424 pPrimOpSpec :: Parser PrimOpSpec
426 = then6 (\_ c n k t o -> PrimOpSpec { cons = c, name = n, ty = t,
427 cat = k, opts = o } )
428 (lit "primop") pConstructor stringLiteral
429 pCategory pType pOptions
431 pOptions :: Parser [Option]
432 pOptions = optdef [] (then2 sel22 (lit "with") (many pOption))
434 pCategory :: Parser Category
437 apply (const Dyadic) (lit "Dyadic"),
438 apply (const Monadic) (lit "Monadic"),
439 apply (const Compare) (lit "Compare"),
440 apply (const GenPrimOp) (lit "GenPrimOp")
444 = lexeme (then3 sel23
445 (char '{') (many (satisfy (not . (== '}'))))
453 pType = then2 (\t maybe_tt -> case maybe_tt of
457 (opt (then2 sel22 (lit "->") pType))
460 paT = alts [ then2 TyApp pTycon (many ppT),
462 then3 sel23 (lit "(") pType (lit ")"),
466 -- the magic bit in the middle is: T (,T)* so to speak
468 = then3 (\ _ ts _ -> TyUTup ts)
470 (then2 (:) pType (many (then2 sel22 (lit ",") pType)))
474 ppT = alts [apply TyVar pTyvar,
475 apply (\tc -> TyApp tc []) pTycon
478 pTyvar = sat (`notElem` ["primop","with"]) pName
479 pTycon = pConstructor
480 pName = lexeme (then2 (:) lower (many isIdChar))
481 pConstructor = lexeme (then2 (:) upper (many isIdChar))
483 isIdChar = satisfy (`elem` idChars)
484 idChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "#_"
492 ------------------------------------------------------------------
493 -- Helpful additions to Daan's parser stuff ----------------------
494 ------------------------------------------------------------------
497 alts (p1:p2:ps) = (try p1) <|> alts (p2:ps)
500 = do x1 <- p1 ; x2 <- p2 ; return (f x1 x2)
502 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; return (f x1 x2 x3)
504 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; return (f x1 x2 x3 x4)
505 then5 f p1 p2 p3 p4 p5
506 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5
507 return (f x1 x2 x3 x4 x5)
508 then6 f p1 p2 p3 p4 p5 p6
509 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6
510 return (f x1 x2 x3 x4 x5 x6)
512 = (do x <- p; return (Just x)) <|> return Nothing
514 = (do x <- p; return x) <|> return d
519 apply f p = liftM f p
521 -- Hacks for zapping whitespace and comments, unfortunately needed
522 -- because Daan won't let us have a lexer before the parser :-(
523 lexeme :: Parser p -> Parser p
524 lexeme p = then2 sel12 p pCommentAndWhitespace
526 lit :: String -> Parser ()
527 lit s = apply (const ()) (lexeme (string s))
529 pCommentAndWhitespace :: Parser ()
530 pCommentAndWhitespace
531 = apply (const ()) (many (alts [pLineComment,
532 apply (const ()) (satisfy isSpace)]))
536 pLineComment :: Parser ()
538 = try (then3 (\_ _ _ -> ()) (string "--") (many (satisfy (/= '\n'))) (char '\n'))
540 stringLiteral :: Parser String
541 stringLiteral = lexeme (
542 do { between (char '"')
543 (char '"' <?> "end of string")
546 <?> "literal string")
550 ------------------------------------------------------------------
552 ------------------------------------------------------------------