diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2020-01-15 22:53:09 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2020-01-15 22:59:41 +0000 |
| commit | 48a58b87c6d5235cda21305840cac1bab97faa11 (patch) | |
| tree | 60eeb57190a77e20b55d905e1af6b12fce86f979 /utils/genprimopcode/Main.hs | |
| parent | 30be3bf13a6e72247ff561df1f291370dad79ef9 (diff) | |
| download | haskell-wip/T17693.tar.gz | |
Work in progress on atomicModifyMutVar2#wip/T17693
This is work in progress for #17693:
improvements for atomicModifyMutVar2#.
Includes:
* Give atomicModifyMutVar2# it correct type in primops.txt.pp
* Use that correct type in GHC.Exts
* Modify genprimopcode to parse that type
Still ToDo:
* Improve the documentation about what exactly it does.
Diffstat (limited to 'utils/genprimopcode/Main.hs')
| -rw-r--r-- | utils/genprimopcode/Main.hs | 15 |
1 files changed, 14 insertions, 1 deletions
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f7b6ba73dd..8e9789b87b 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -79,6 +79,7 @@ desugarVectorSpec i = case vecOptions i of desugarTy (TyApp tycon ts) = TyApp tycon (map desugarTy ts) desugarTy t@(TyVar {}) = t desugarTy (TyUTup ts) = TyUTup (map desugarTy ts) + desugarTy (TyTup ts) = TyTup (map desugarTy ts) conCat :: String -> String conCat "Int8" = "IntVec" @@ -414,6 +415,9 @@ pprTy = pty pty t = pbty t pbty (TyApp tc ts) = unwords (wrapOp (show tc) : map paty ts) + pbty (TyTup ts) = "(" + ++ concat (intersperse "," (map pty ts)) + ++ ")" pbty (TyUTup ts) = "(# " ++ concat (intersperse "," (map pty ts)) ++ " #)" @@ -477,6 +481,7 @@ gen_latex_doc (Info defaults entries) pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts))) + pbty (TyTup ts) = "(" ++ (concat (intersperse "," (map pty ts))) ++ ")" pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" pbty t = paty t paty (TyVar tv) = tv @@ -487,13 +492,16 @@ gen_latex_doc (Info defaults entries) pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts))) + pbty (TyTup ts) = (zencode (tuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) pbty t = paty t paty (TyVar tv) = zencode tv paty (TyApp tc []) = zencode (show tc) paty t = "(" ++ pty t ++ ")" - utuplenm 1 = "(# #)" + utuplenm 0 = "(# #)" utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" + tuplenm 0 = "()" + tuplenm n = "(" ++ (replicate (n-1) ',') ++ ")" foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) tvars = tvars_of typ tbinds [] = ". " @@ -503,6 +511,7 @@ gen_latex_doc (Info defaults entries) tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2 tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts) tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) + tvars_of (TyTup ts) = foldr union [] (map tvars_of ts) tvars_of (TyVar tv) = [tv] mk_options o = @@ -895,6 +904,8 @@ ppType (TyApp (VecTyCon _ pptc) []) = pptc ppType (TyUTup ts) = "(mkTupleTy Unboxed " ++ listify (map ppType ts) ++ ")" +ppType (TyTup ts) = "(mkTupleTy Boxed " + ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkVisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" ppType (TyC s d) = "(mkInvisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" @@ -920,6 +931,7 @@ tvsIn (TyF t1 t2) = tvsIn t1 ++ tvsIn t2 tvsIn (TyC t1 t2) = tvsIn t1 ++ tvsIn t2 tvsIn (TyApp _ tys) = concatMap tvsIn tys tvsIn (TyVar tv) = [tv] +tvsIn (TyTup tys) = concatMap tvsIn tys tvsIn (TyUTup tys) = concatMap tvsIn tys tyconsIn :: Ty -> [TyCon] @@ -928,6 +940,7 @@ tyconsIn (TyC 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 +tyconsIn (TyTup tys) = foldr union [] $ map tyconsIn tys arity :: Ty -> Int arity = length . fst . flatTys |