diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-07-21 08:07:41 +0000 |
---|---|---|
committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2016-07-21 08:11:27 +0000 |
commit | 714bebff44076061d0a719c4eda2cfd213b7ac3d (patch) | |
tree | b697e786a8f5f25e8a47886bc5d5487c01678ec6 /compiler/ghci/ByteCodeGen.hs | |
parent | 83e4f49577665278fe08fbaafe2239553f3c448e (diff) | |
download | haskell-714bebff44076061d0a719c4eda2cfd213b7ac3d.tar.gz |
Implement unboxed sum primitive type
Summary:
This patch implements primitive unboxed sum types, as described in
https://ghc.haskell.org/trac/ghc/wiki/UnpackedSumTypes.
Main changes are:
- Add new syntax for unboxed sums types, terms and patterns. Hidden
behind `-XUnboxedSums`.
- Add unlifted unboxed sum type constructors and data constructors,
extend type and pattern checkers and desugarer.
- Add new RuntimeRep for unboxed sums.
- Extend unarise pass to translate unboxed sums to unboxed tuples right
before code generation.
- Add `StgRubbishArg` to `StgArg`, and a new type `CmmArg` for better
code generation when sum values are involved.
- Add user manual section for unboxed sums.
Some other changes:
- Generalize `UbxTupleRep` to `MultiRep` and `UbxTupAlt` to
`MultiValAlt` to be able to use those with both sums and tuples.
- Don't use `tyConPrimRep` in `isVoidTy`: `tyConPrimRep` is really
wrong, given an `Any` `TyCon`, there's no way to tell what its kind
is, but `kindPrimRep` and in turn `tyConPrimRep` returns `PtrRep`.
- Fix some bugs on the way: #12375.
Not included in this patch:
- Update Haddock for new the new unboxed sum syntax.
- `TemplateHaskell` support is left as future work.
For reviewers:
- Front-end code is mostly trivial and adapted from unboxed tuple code
for type checking, pattern checking, renaming, desugaring etc.
- Main translation routines are in `RepType` and `UnariseStg`.
Documentation in `UnariseStg` should be enough for understanding
what's going on.
Credits:
- Johan Tibell wrote the initial front-end and interface file
extensions.
- Simon Peyton Jones reviewed this patch many times, wrote some code,
and helped with debugging.
Reviewers: bgamari, alanz, goldfire, RyanGlScott, simonpj, austin,
simonmar, hvr, erikd
Reviewed By: simonpj
Subscribers: Iceland_jack, ggreif, ezyang, RyanGlScott, goldfire,
thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D2259
Diffstat (limited to 'compiler/ghci/ByteCodeGen.hs')
-rw-r--r-- | compiler/ghci/ByteCodeGen.hs | 148 |
1 files changed, 62 insertions, 86 deletions
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 8839ffa544..9c7d25a5ec 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -31,6 +31,7 @@ import Literal import PrimOp import CoreFVs import Type +import RepType import Kind ( isLiftedTypeKind ) import DataCon import TyCon @@ -303,8 +304,8 @@ collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' go xs (AnnLam x (_,e)) - | UbxTupleRep _ <- repType (idType x) - = unboxedTupleException + | repTypeArgs (idType x) `lengthExceeds` 1 + = multiValException | otherwise = go (x:xs) e go xs not_lambda = (reverse xs, not_lambda) @@ -532,8 +533,9 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut -- no alts: scrut is guaranteed to diverge schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc - , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2) + | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token) + , [rep_ty1] <- repTypeArgs (idType bind1) + , [rep_ty2] <- repTypeArgs (idType bind2) -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } -- to @@ -543,43 +545,25 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. , Just res <- case () of - _ | VoidRep <- typePrimRep rep_ty1 - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | VoidRep <- typePrimRep rep_ty2 - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} + _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2) + -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr) + | isVoidTy rep_ty2 && not (isVoidTy rep_ty1) + -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) | otherwise -> Nothing = res schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) - | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1) - -- Similarly, convert - -- case .... of x { (# a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - -schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)]) - | Just (tc, tys) <- splitTyConApp_maybe (idType bndr) - , isUnboxedTupleTyCon tc - , Just res <- case tys of - [ty] | UnaryRep _ <- repType ty - , let bind = bndr `setIdType` ty - -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1 - , UnaryRep rep_ty2 <- repType ty2 - -> case () of - _ | VoidRep <- typePrimRep rep_ty1 - , let bind2 = bndr `setIdType` ty2 - -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | VoidRep <- typePrimRep rep_ty2 - , let bind1 = bndr `setIdType` ty1 - -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-} - | otherwise - -> Nothing - _ -> Nothing - = res + | isUnboxedTupleCon dc + , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples + = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) + +schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)]) + | isUnboxedTupleType (idType bndr) + , [ty] <- repTypeArgs (idType bndr) + -- handles any pattern with a single non-void binder; in particular I/O + -- monad returns (# RealWorld#, a #) + = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr) schemeE d s p (AnnCase scrut bndr _ alts) = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-} @@ -647,14 +631,14 @@ schemeT d s p app -- Case 2: Constructor application - | Just con <- maybe_saturated_dcon, - isUnboxedTupleCon con + | Just con <- maybe_saturated_dcon + , isUnboxedTupleCon con = case args_r_to_l of [arg1,arg2] | isVAtom arg1 -> unboxedTupleReturn d s p arg2 [arg1,arg2] | isVAtom arg2 -> unboxedTupleReturn d s p arg1 - _other -> unboxedTupleException + _other -> multiValException -- Case 3: Ordinary data constructor | Just con <- maybe_saturated_dcon @@ -792,8 +776,8 @@ doCase :: Word -> Sequel -> BCEnv -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result -> BcM BCInstrList doCase d s p (_,scrut) bndr alts is_unboxed_tuple - | UbxTupleRep _ <- repType (idType bndr) - = unboxedTupleException + | repTypeArgs (idType bndr) `lengthExceeds` 1 + = multiValException | otherwise = do dflags <- getDynFlags @@ -848,8 +832,6 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | null real_bndrs = do rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) - | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs - = unboxedTupleException -- algebraic alt with some binders | otherwise = let @@ -872,8 +854,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) - | isUnboxedTupleCon dc - = unboxedTupleException + | isUnboxedTupleCon dc || isUnboxedSumCon dc + = multiValException | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) my_discr (LitAlt l, _, _) @@ -971,7 +953,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l pargs _ [] = return [] pargs d (a:az) - = let UnaryRep arg_ty = repType (exprType (deAnnotate' a)) + = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a)) in case tyConAppTyCon_maybe arg_ty of -- Don't push the FO; instead push the Addr# it @@ -1104,10 +1086,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- this is a V (tag). r_sizeW = fromIntegral (primRepSizeW dflags r_rep) d_after_r = d_after_Addr + fromIntegral r_sizeW - r_lit = mkDummyLiteral r_rep push_r = (if returns_void then nilOL - else unitOL (PUSH_UBX r_lit r_sizeW)) + else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW)) -- generate the marshalling code we're going to call @@ -1176,7 +1157,7 @@ mkDummyLiteral pr FloatRep -> MachFloat 0 Int64Rep -> MachInt64 0 Word64Rep -> MachWord64 0 - _ -> panic "mkDummyLiteral" + _ -> pprPanic "mkDummyLiteral" (ppr pr) -- Convert (eg) @@ -1195,27 +1176,26 @@ mkDummyLiteral pr maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty - = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - maybe_r_rep_to_go - = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - r_reps = case repType r_ty of - UbxTupleRep reps -> map typePrimRep reps - UnaryRep _ -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) - && case maybe_r_rep_to_go of - Nothing -> True - Just r_rep -> r_rep /= PtrRep - -- if it was, it would be impossible - -- to create a valid return value - -- placeholder on the stack - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + r_reps = repTypeArgs r_ty + + blargh :: a -- Used at more than one type + blargh = pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) in - --trace (showSDoc (ppr (a_reps, r_reps))) $ - if ok then maybe_r_rep_to_go else blargh + case r_reps of + [] -> panic "empty repTypeArgs" + [ty] + | typePrimRep ty == PtrRep + -> blargh + | isVoidTy ty + -> Nothing + | otherwise + -> Just (typePrimRep ty) + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> blargh maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name]) -- Detect and extract relevant info for the tagToEnum kludge. @@ -1227,14 +1207,14 @@ maybe_is_tagToEnum_call app = Nothing where extract_constr_Names ty - | UnaryRep rep_ty <- repType ty - , Just tyc <- tyConAppTyCon_maybe rep_ty, - isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.hs for details. + | [rep_ty] <- repTypeArgs ty + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.hs for details. | otherwise - = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) {- ----------------------------------------------------------------------------- Note [Implementing tagToEnum#] @@ -1334,7 +1314,7 @@ pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128 = pushAtom d p a pushAtom d p (AnnVar v) - | UnaryRep rep_ty <- repType (idType v) + | [rep_ty] <- repTypeArgs (idType v) , V <- typeArgRep rep_ty = return (nilOL, 0) @@ -1556,18 +1536,14 @@ isVoidArg V = True isVoidArg _ = False bcIdUnaryType :: Id -> UnaryType -bcIdUnaryType x = case repType (idType x) of - UnaryRep rep_ty -> rep_ty - UbxTupleRep [rep_ty] -> rep_ty - UbxTupleRep [rep_ty1, rep_ty2] - | VoidRep <- typePrimRep rep_ty1 -> rep_ty2 - | VoidRep <- typePrimRep rep_ty2 -> rep_ty1 +bcIdUnaryType x = case repTypeArgs (idType x) of + [rep_ty] -> rep_ty _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x)) -- See bug #1257 -unboxedTupleException :: a -unboxedTupleException = throwGhcException (ProgramError - ("Error: bytecode compiler can't handle unboxed tuples.\n"++ +multiValException :: a +multiValException = throwGhcException (ProgramError + ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++ " Possibly due to foreign import/export decls in source.\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) |