diff options
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 2 | ||||
| -rwxr-xr-x | libraries/base/GHC/Exts.hs | 7 | ||||
| -rw-r--r-- | utils/genprimopcode/Main.hs | 15 | ||||
| -rw-r--r-- | utils/genprimopcode/Parser.y | 4 | ||||
| -rw-r--r-- | utils/genprimopcode/Syntax.hs | 3 |
5 files changed, 25 insertions, 6 deletions
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 4180152460..9ae9dc9a37 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -2534,7 +2534,7 @@ primop SameMutVarOp "sameMutVar#" GenPrimOp -- atomic compare-and-swap as it is merely replacing a pointer. primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp - MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) + MutVar# s a -> (a -> (a, b)) -> State# s -> (# State# s, a, (a, b) #) { Modify the contents of a {\tt MutVar\#}, returning the previous contents and the result of applying the given function to the previous contents. Note that this isn't strictly diff --git a/libraries/base/GHC/Exts.hs b/libraries/base/GHC/Exts.hs index 9bce21cd27..17206aecd6 100755 --- a/libraries/base/GHC/Exts.hs +++ b/libraries/base/GHC/Exts.hs @@ -104,6 +104,7 @@ import GHC.Word import GHC.Int import GHC.Ptr import GHC.Stack +import Data.Tuple( snd ) import qualified Data.Coerce import Data.String @@ -258,12 +259,12 @@ instance IsList CallStack where -- types. atomicModifyMutVar# :: MutVar# s a - -> (a -> b) + -> (a -> (b,c)) -> State# s -> (# State# s, c #) atomicModifyMutVar# mv f s = - case unsafeCoerce# (atomicModifyMutVar2# mv f s) of - (# s', _, ~(_, res) #) -> (# s', res #) + case atomicModifyMutVar2# mv f s of + (# s', _, res #) -> (# s', snd res #) -- | Resize a mutable array to new specified size. The returned -- 'SmallMutableArray#' is either the original 'SmallMutableArray#' 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 diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index 89e61d5236..7f3ebeb6bf 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -162,12 +162,16 @@ pType : paT '->' pType { TyF $1 $3 } paT :: { Ty } paT : pTycon ppTs { TyApp $1 $2 } | pUnboxedTupleTy { $1 } + | pBoxedTupleTy { $1 } | '(' pType ')' { $2 } | lowerName { TyVar $1 } pUnboxedTupleTy :: { Ty } pUnboxedTupleTy : '(#' pCommaTypes '#)' { TyUTup $2 } +pBoxedTupleTy :: { Ty } +pBoxedTupleTy : '(' pType ',' pCommaTypes ')' { TyTup ($2:$4) } + pCommaTypes :: { [Ty] } pCommaTypes : pType ',' pCommaTypes { $1 : $3 } | pType { [$1] } diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index 4dc6e7b2dc..040061247a 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -74,7 +74,8 @@ data 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, + | TyTup [Ty] + | TyUTup [Ty] -- unboxed tuples; just a TyCon really, -- but convenient like this deriving (Eq,Show) |