X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fgenprimopcode%2FMain.hs;h=71b1e76598d5ab5778647cabcd9f024b61cff6e2;hb=00ed85dad9ef70f200240790693dc436b479b38b;hp=8cfbed3d499159664aa6cc4e37baba5784b77359;hpb=07d1b116efe38566ef51286121da1fc60ef33b16;p=ghc-hetmet.git diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 8cfbed3..71b1e76 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -146,25 +146,15 @@ gen_hs_source (Info defaults entries) = spec o = comm ++ decl where decl = case o of - PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t - PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pty t - PrimTypeSpec { ty = t } -> "data " ++ pty t + PrimOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pprTy t + PseudoOpSpec { name = n, ty = t } -> wrapOp n ++ " :: " ++ pprTy t + PrimTypeSpec { ty = t } -> "data " ++ pprTy t Section { } -> "" comm = case (desc o) of [] -> "" d -> "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ d) - pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 - pty t = pbty t - - pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" - pbty t = paty t - - paty (TyVar tv) = tv - paty t = "(" ++ pty t ++ ")" - wrapOp nm | isAlpha (head nm) = nm | otherwise = "(" ++ nm ++ ")" wrapTy nm | isAlpha (head nm) = nm @@ -183,6 +173,19 @@ gen_hs_source (Info defaults entries) = escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[]) where special = "/'`\"@<" +pprTy = pty + where + pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + pty t = pbty t + pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts)) + pbty (TyUTup ts) = "(# " + ++ concat (intersperse "," (map pty ts)) + ++ " #)" + pbty t = paty t + + paty (TyVar tv) = tv + paty t = "(" ++ pty t ++ ")" +-- -- Generates the type environment that the stand-alone External Core tools use. gen_ext_core_source :: [Entry] -> String gen_ext_core_source entries = @@ -190,7 +193,9 @@ gen_ext_core_source entries = ++ "-- This module is automatically generated by the GHC utility\n" ++ "-- \"genprimopcode\". Do not edit!\n" ++ "-----------------------------------------------------------------------\n" - ++ "module PrimEnv(primTcs, primVals) where\nimport Core\nimport Encoding\n\n" + ++ "module Language.Core.PrimEnv(primTcs, primVals, intLitTypes, ratLitTypes," + ++ "\n charLitTypes, stringLitTypes) where\nimport Language.Core.Core" + ++ "\nimport Language.Core.Encoding\n\n" ++ "primTcs :: [(Tcon, Kind)]\n" ++ "primTcs = [\n" ++ printList tcEnt entries @@ -198,7 +203,24 @@ gen_ext_core_source entries = ++ "primVals :: [(Var, Ty)]\n" ++ "primVals = [\n" ++ printList valEnt entries + ++ "]\n" + ++ "intLitTypes :: [Ty]\n" + ++ "intLitTypes = [\n" + ++ printList tyEnt (intLitTys entries) + ++ "]\n" + ++ "ratLitTypes :: [Ty]\n" + ++ "ratLitTypes = [\n" + ++ printList tyEnt (ratLitTys entries) + ++ "]\n" + ++ "charLitTypes :: [Ty]\n" + ++ "charLitTypes = [\n" + ++ printList tyEnt (charLitTys entries) + ++ "]\n" + ++ "stringLitTypes :: [Ty]\n" + ++ "stringLitTypes = [\n" + ++ printList tyEnt (stringLitTys entries) ++ "]\n\n" + where printList f = concat . intersperse ",\n" . filter (not . null) . map f tcEnt (PrimTypeSpec {ty=t}) = case t of @@ -253,20 +275,31 @@ gen_ext_core_source entries = tapp s nextArg = paren $ "Tapp " ++ s ++ " " ++ paren nextArg tcUTuple n = paren $ "Tcon " ++ paren (qualify False $ "Z" ++ show n ++ "H") - -- more hacks. might be better to do this on the ext-core side, - -- as per earlier comment - qualify _ tc | tc == "ByteArr#" = qualify True "ByteArray#" - qualify _ tc | tc == "MutArr#" = qualify True "MutableArray#" - qualify _ tc | tc == "MutByteArr#" = - qualify True "MutableByteArray#" - qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " + + tyEnt (PrimTypeSpec {ty=(TyApp tc args)}) = " " ++ paren ("Tcon " ++ + (paren (qualify True tc))) + tyEnt _ = "" + + -- more hacks. might be better to do this on the ext-core side, + -- as per earlier comment + qualify _ tc | tc == "Bool" = "Just boolMname" ++ ", " ++ ze True tc - qualify _ tc | tc == "()" = "Just baseMname" ++ ", " + qualify _ tc | tc == "()" = "Just baseMname" ++ ", " ++ ze True tc - qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc) - ze enc tc = (if enc then "zEncodeString " else "") + qualify enc tc = "Just primMname" ++ ", " ++ (ze enc tc) + ze enc tc = (if enc then "zEncodeString " else "") ++ "\"" ++ tc ++ "\"" + intLitTys = prefixes ["Int", "Word", "Addr", "Char"] + ratLitTys = prefixes ["Float", "Double"] + charLitTys = prefixes ["Char"] + stringLitTys = prefixes ["Addr"] + prefixes ps = filter (\ t -> + case t of + (PrimTypeSpec {ty=(TyApp tc args)}) -> + any (\ p -> p `isPrefixOf` tc) ps + _ -> False) + parens n ty = " (zEncodeString \"" ++ n ++ "\", " ++ ty ++ ")" paren s = "(" ++ s ++ ")" quot s = "\"" ++ s ++ "\"" @@ -431,18 +464,27 @@ gen_latex_doc (Info defaults entries) gen_wrappers :: Info -> String gen_wrappers (Info _ entries) - = "{-# OPTIONS -fno-implicit-prelude #-}\n" + = "{-# LANGUAGE NoImplicitPrelude, UnboxedTuples #-}\n" -- Dependencies on Prelude must be explicit in libraries/base, but we - -- don't need the Prelude here so we add -fno-implicit-prelude. + -- don't need the Prelude here so we add NoImplicitPrelude. ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" - ++ unlines (map f (filter (not.dodgy) (filter is_primop entries))) + ++ "import GHC.Bool (Bool)\n" + ++ "import GHC.Unit ()\n" + ++ "import GHC.Prim (" ++ types ++ ")\n" + ++ unlines (concatMap f specs) where + specs = filter (not.dodgy) (filter is_primop entries) + tycons = foldr union [] $ map (tyconsIn . ty) specs + tycons' = filter (`notElem` ["()", "Bool"]) tycons + types = concat $ intersperse ", " tycons' f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) - in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++ - src_name ++ " " ++ unwords args - ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args + lhs = src_name ++ " " ++ unwords args + rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args + in ["{-# NOINLINE " ++ src_name ++ " #-}", + src_name ++ " :: " ++ pprTy (ty spec), + lhs ++ " = " ++ rhs] wrap nm | isLower (head nm) = nm | otherwise = "(" ++ nm ++ ")" @@ -547,7 +589,7 @@ mkPOI_RHS_text i ++ "(" ++ ppType resTy ++ ")" sl_name :: Entry -> String -sl_name i = "FSLIT(\"" ++ name i ++ "\") " +sl_name i = "(fsLit \"" ++ name i ++ "\") " ppTyVar :: String -> String ppTyVar "a" = "alphaTyVar" @@ -570,7 +612,7 @@ ppType (TyApp "Word64#" []) = "word64PrimTy" ppType (TyApp "Addr#" []) = "addrPrimTy" ppType (TyApp "Float#" []) = "floatPrimTy" ppType (TyApp "Double#" []) = "doublePrimTy" -ppType (TyApp "ByteArr#" []) = "byteArrayPrimTy" +ppType (TyApp "ByteArray#" []) = "byteArrayPrimTy" ppType (TyApp "RealWorld" []) = "realWorldTy" ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" @@ -585,10 +627,10 @@ ppType (TyVar "o") = "openAlphaTy" ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyApp "MutArr#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x - ++ " " ++ ppType y +ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x + ++ " " ++ ppType y -ppType (TyApp "MutByteArr#" [x]) = "mkMutableByteArrayPrimTy " +ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " ++ ppType x ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x @@ -624,6 +666,12 @@ tvsIn (TyApp _ tys) = concatMap tvsIn tys tvsIn (TyVar tv) = [tv] tvsIn (TyUTup tys) = concatMap tvsIn tys +tyconsIn :: Ty -> [TyCon] +tyconsIn (TyF t1 t2) = tyconsIn t1 `union` tyconsIn t2 +tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys +tyconsIn (TyVar _) = [] +tyconsIn (TyUTup tys) = foldr union [] $ map tyconsIn tys + arity :: Ty -> Int arity = length . fst . flatTys