From 10fcd78ccde892feccda3f5eacd221c1de75feea Mon Sep 17 00:00:00 2001 From: chak Date: Mon, 11 Feb 2002 08:20:50 +0000 Subject: [PATCH] [project @ 2002-02-11 08:20:38 by chak] ******************************* * Merging from ghc-ndp-branch * ******************************* This commit merges the current state of the "parallel array extension" and includes the following: * (Almost) completed Milestone 1: - The option `-fparr' activates the H98 extension for parallel arrays. - These changes have a high likelihood of conflicting (in the CVS sense) with other changes to GHC and are the reason for merging now. - ToDo: There are still some (less often used) functions not implemented in `PrelPArr' and a mechanism is needed to automatically import `PrelPArr' iff `-fparr' is given. Documentation that should go into the Commentary is currently in `ghc/compiler/ndpFlatten/TODO'. * Partial Milestone 2: - The option `-fflatten' activates the flattening transformation and `-ndp' selects the "ndp" way (where all libraries have to be compiled with flattening). The way option `-ndp' automagically turns on `-fparr' and `-fflatten'. - Almost all changes are in the new directory `ndpFlatten' and shouldn't affect the rest of the compiler. The only exception are the options and the points in `HscMain' where the flattening phase is called when `-fflatten' is given. - This isn't usable yet, but already implements function lifting, vectorisation, and a new analysis that determines which parts of a module have to undergo the flattening transformation. Missing are data structure and function specialisation, the unboxed array library (including fusion rules), and lots of testing. I have just run the regression tests on the thing without any problems. So, it seems, as if we haven't broken anything crucial. --- ghc/compiler/Makefile | 4 +- ghc/compiler/basicTypes/Unique.lhs | 5 + ghc/compiler/deSugar/Check.lhs | 25 +- ghc/compiler/deSugar/DsExpr.lhs | 69 ++- ghc/compiler/deSugar/DsListComp.lhs | 167 ++++++- ghc/compiler/deSugar/DsUtils.lhs | 82 +++- ghc/compiler/deSugar/Match.lhs | 15 +- ghc/compiler/hsSyn/HsExpr.lhs | 55 ++- ghc/compiler/hsSyn/HsPat.lhs | 40 +- ghc/compiler/hsSyn/HsSyn.lhs | 22 +- ghc/compiler/hsSyn/HsTypes.lhs | 15 +- ghc/compiler/main/CmdLineOpts.lhs | 5 + ghc/compiler/main/DriverFlags.hs | 5 +- ghc/compiler/main/DriverState.hs | 11 +- ghc/compiler/main/HscMain.lhs | 45 +- ghc/compiler/main/ParsePkgConf.y | 7 +- ghc/compiler/ndpFlatten/FlattenInfo.hs | 43 ++ ghc/compiler/ndpFlatten/FlattenMonad.hs | 454 +++++++++++++++++ ghc/compiler/ndpFlatten/Flattening.hs | 812 +++++++++++++++++++++++++++++++ ghc/compiler/ndpFlatten/NDPCoreUtils.hs | 175 +++++++ ghc/compiler/ndpFlatten/PArrAnal.hs | 202 ++++++++ ghc/compiler/ndpFlatten/TODO | 202 ++++++++ ghc/compiler/parser/Lex.lhs | 200 +++++--- ghc/compiler/parser/ParseUtil.lhs | 2 + ghc/compiler/parser/Parser.y | 43 +- ghc/compiler/parser/RdrHsSyn.lhs | 1 + ghc/compiler/prelude/PrelNames.lhs | 125 ++++- ghc/compiler/prelude/TysWiredIn.lhs | 110 ++++- ghc/compiler/rename/ParseIface.y | 21 +- ghc/compiler/rename/RnEnv.lhs | 7 +- ghc/compiler/rename/RnExpr.lhs | 58 ++- ghc/compiler/rename/RnHiFiles.lhs | 9 +- ghc/compiler/rename/RnHsSyn.lhs | 6 +- ghc/compiler/rename/RnTypes.lhs | 4 + ghc/compiler/simplCore/SimplCore.lhs | 5 +- ghc/compiler/typecheck/TcExpr.lhs | 77 ++- ghc/compiler/typecheck/TcHsSyn.lhs | 20 +- ghc/compiler/typecheck/TcMType.lhs | 2 - ghc/compiler/typecheck/TcMonad.lhs | 3 + ghc/compiler/typecheck/TcMonoType.lhs | 10 +- ghc/compiler/typecheck/TcPat.lhs | 13 +- ghc/compiler/typecheck/TcSimplify.lhs | 8 +- ghc/compiler/typecheck/TcUnify.lhs | 24 +- ghc/compiler/types/PprType.lhs | 8 + ghc/lib/std/Makefile | 1 + ghc/lib/std/PrelPArr.hs | 644 ++++++++++++++++++++++++ 46 files changed, 3646 insertions(+), 215 deletions(-) create mode 100644 ghc/compiler/ndpFlatten/FlattenInfo.hs create mode 100644 ghc/compiler/ndpFlatten/FlattenMonad.hs create mode 100644 ghc/compiler/ndpFlatten/Flattening.hs create mode 100644 ghc/compiler/ndpFlatten/NDPCoreUtils.hs create mode 100644 ghc/compiler/ndpFlatten/PArrAnal.hs create mode 100644 ghc/compiler/ndpFlatten/TODO create mode 100644 ghc/lib/std/PrelPArr.hs diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 85b577e..33bbd9e 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.208 2002/02/08 15:02:30 simonmar Exp $ +# $Id: Makefile,v 1.209 2002/02/11 08:20:38 chak Exp $ TOP = .. @@ -96,7 +96,7 @@ CLEAN_FILES += $(CONFIG_HS) ALL_DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser usageSP cprAnalysis compMan + profiling parser usageSP cprAnalysis compMan ndpFlatten # Make sure we include Config.hs even if it doesn't exist yet... ALL_SRCS += $(CONFIG_HS) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 510e728..44c8c07 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -40,6 +40,7 @@ module Unique ( mkTupleTyConUnique, mkTupleDataConUnique, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, + mkPArrDataConUnique, mkBuiltinUnique, mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3 @@ -322,6 +323,10 @@ isTupleKey u = case unpkUnique u of mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i +-- No numbers left anymore, so I pick something different for the character +-- tag +mkPArrDataConUnique a = mkUnique ':' (2*a) + -- The "tyvar uniques" print specially nicely: a, b, c, etc. -- See pprUnique for details diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 17e0e52..d445834 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -142,6 +142,8 @@ untidy b (ConPatIn name pats) = untidy b (ConOpPatIn pat1 name fixity pat2) = pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2)) untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats) +untidy _ (PArrPatIn pats) = + panic "Check.untidy: Shouldn't get a parallel array here!" untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat) @@ -523,12 +525,26 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints) where name = getName id fixity = panic "Check.make_con: Guessing fixity" -make_con (ConPat id _ _ _ pats) (ps,constraints) +make_con (ConPat id _ _ _ pats) (ps, constraints) | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) | otherwise = (ConPatIn name pats_con : rest_pats, constraints) where name = getName id (pats_con, rest_pats) = splitAtList pats ps tc = dataConTyCon id + +-- reconstruct parallel array pattern +-- +-- * don't check for the type only; we need to make sure that we are really +-- dealing with one of the fake constructors and not with the real +-- representation +-- +make_con (ConPat id _ _ _ pats) (ps, constraints) + | isPArrFakeCon id = (PArrPatIn patsCon : restPats, constraints) + | otherwise = (ConPatIn name patsCon : restPats, constraints) + where + name = getName id + (patsCon, restPats) = splitAtList pats ps + tc = dataConTyCon id make_whole_con :: DataCon -> WarningPat @@ -575,6 +591,13 @@ simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] (map simplify_pat ps) where list_ty = mkListTy ty +-- introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +-- +simplify_pat (PArrPat ty ps) + = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps) + where + arity = length ps simplify_pat (TuplePat ps boxity) = ConPat (tupleCon boxity arity) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 162ae24..5d7ff19 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -32,7 +32,7 @@ import DsMonad import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) import DsCCall ( dsCCall, resultWrapper ) -import DsListComp ( dsListComp ) +import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringLit, mkStringLitFS, mkConsExpr, mkNilExpr, mkIntegerLit ) @@ -49,7 +49,7 @@ import TyCon ( tyConDataCons ) import TysWiredIn ( tupleCon, listTyCon, charDataCon, intDataCon ) import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) import Maybes ( maybeToBool ) -import PrelNames ( hasKey, ratioTyConKey ) +import PrelNames ( hasKey, ratioTyConKey, toPName ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -262,27 +262,26 @@ dsExpr (HsWith expr binds) = dsExpr e `thenDs` \ e' -> returnDs (Let (NonRec (ipNameName n) e') body) -dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) - | maybeToBool maybe_list_comp +-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) +-- because the interpretation of `stmts' depends on what sort of thing it is. +-- +dsExpr (HsDoOut ListComp stmts return_id then_id fail_id result_ty src_loc) = -- Special case for list comprehensions putSrcLocDs src_loc $ dsListComp stmts elt_ty + where + (_, [elt_ty]) = tcSplitTyConApp result_ty - | otherwise +dsExpr (HsDoOut DoExpr stmts return_id then_id fail_id result_ty src_loc) = putSrcLocDs src_loc $ - dsDo do_or_lc stmts return_id then_id fail_id result_ty + dsDo DoExpr stmts return_id then_id fail_id result_ty + +dsExpr (HsDoOut PArrComp stmts return_id then_id fail_id result_ty src_loc) + = -- Special case for array comprehensions + putSrcLocDs src_loc $ + dsPArrComp stmts elt_ty where - maybe_list_comp - = case (do_or_lc, tcSplitTyConApp_maybe result_ty) of - (ListComp, Just (tycon, [elt_ty])) - | tycon == listTyCon - -> Just elt_ty - other -> Nothing - -- We need the ListComp form to use deListComp (rather than the "do" form) - -- because the interpretation of ExprStmt depends on what sort of thing - -- it is. - - Just elt_ty = maybe_list_comp + (_, [elt_ty]) = tcSplitTyConApp result_ty dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -319,6 +318,21 @@ dsExpr (ExplicitList ty xs) go xs `thenDs` \ core_xs -> returnDs (mkConsExpr ty core_x core_xs) +-- we create a list from the array elements and convert them into a list using +-- `PrelPArr.toP' +-- +-- * the main disadvantage to this scheme is that `toP' traverses the list +-- twice: once to determine the length and a second time to put to elements +-- into the array; this inefficiency could be avoided by exposing some of +-- the innards of `PrelPArr' to the compiler (ie, have a `PrelPArrBase') so +-- that we can exploit the fact that we already know the length of the array +-- here at compile time +-- +dsExpr (ExplicitPArr ty xs) + = dsLookupGlobalValue toPName `thenDs` \toP -> + dsExpr (ExplicitList ty xs) `thenDs` \coreList -> + returnDs (mkApps (Var toP) [Type ty, coreList]) + dsExpr (ExplicitTuple expr_list boxity) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) @@ -347,6 +361,24 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two)) dsExpr thn `thenDs` \ thn2 -> dsExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, thn2, two2]) + +dsExpr (PArrSeqOut expr (FromTo from two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr two `thenDs` \ two2 -> + returnDs (mkApps expr2 [from2, two2]) + +dsExpr (PArrSeqOut expr (FromThenTo from thn two)) + = dsExpr expr `thenDs` \ expr2 -> + dsExpr from `thenDs` \ from2 -> + dsExpr thn `thenDs` \ thn2 -> + dsExpr two `thenDs` \ two2 -> + returnDs (mkApps expr2 [from2, thn2, two2]) + +dsExpr (PArrSeqOut expr _) + = panic "DsExpr.dsExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer and typechecker + -- shouldn't have let it through \end{code} \noindent @@ -512,6 +544,7 @@ dsExpr (DictApp expr dicts) -- becomes a curried application dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo" dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" +dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn" #endif \end{code} @@ -534,7 +567,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty (_, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) is_do = case do_or_lc of DoExpr -> True - ListComp -> False + _ -> False -- For ExprStmt, see the comments near HsExpr.Stmt about -- exactly what ExprStmts mean! diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index ebe08c6..99b8980 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -1,18 +1,23 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[DsListComp]{Desugaring list comprehensions} +\section[DsListComp]{Desugaring list comprehensions and array comprehensions} \begin{code} -module DsListComp ( dsListComp ) where +module DsListComp ( dsListComp, dsPArrComp ) where #include "HsVersions.h" import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) -import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..) ) -import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, outPatType ) +import DataCon ( dataConId ) +import TyCon ( tyConName ) +import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), + HsMatchContext(..), HsDoContext(..), + collectHsOutBinders ) +import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, + outPatType ) import CoreSyn import DsMonad -- the monadery used in the desugarer @@ -22,12 +27,18 @@ import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id ) -import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) +import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type, + splitTyConApp_maybe ) import TysPrim ( alphaTyVar ) -import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, mkListTy, mkTupleTy ) +import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, unitTy, + mkListTy, mkTupleTy, intDataCon ) import Match ( matchSimply ) -import PrelNames ( foldrName, buildName ) +import PrelNames ( trueDataConName, falseDataConName, foldrName, + buildName, replicatePName, mapPName, filterPName, + zipPName, crossPName, parrTyConName ) +import PrelInfo ( pAT_ERROR_ID ) import SrcLoc ( noSrcLoc ) +import Panic ( panic ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -319,4 +330,146 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) ) \end{code} +%************************************************************************ +%* * +\subsection[DsPArrComp]{Desugaring of array comprehensions} +%* * +%************************************************************************ + +\begin{code} + +-- entry point for desugaring a parallel array comprehension +-- +-- [:e | qss:] = <<[:e | qss:]>> () [:():] +-- +dsPArrComp :: [TypecheckedStmt] + -> Type -- Don't use; called with `undefined' below + -> DsM CoreExpr +dsPArrComp qs _ = + dsLookupGlobalValue replicatePName `thenDs` \repP -> + let unitArray = mkApps (Var repP) [Type unitTy, + mkConApp intDataCon [mkIntLit 1], + mkTupleExpr []] + in + dePArrComp qs (TuplePat [] Boxed) unitArray +-- the work horse +-- +dePArrComp :: [TypecheckedStmt] + -> TypecheckedPat -- the current generator pattern + -> CoreExpr -- the current generator expression + -> DsM CoreExpr +-- +-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea +-- +dePArrComp [ResultStmt e' _] pa cea = + dsLookupGlobalValue mapPName `thenDs` \mapP -> + let ty = parrElemType cea + in + deLambda ty pa e' `thenDs` \(clam, + ty'e') -> + returnDs $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] +-- +-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) +-- +dePArrComp (ExprStmt b _ _ : qs) pa cea = + dsLookupGlobalValue filterPName `thenDs` \filterP -> + let ty = parrElemType cea + in + deLambda ty pa b `thenDs` \(clam,_) -> + dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) +-- +-- <<[:e' | p <- e, qs:]>> pa ea = +-- let ef = filterP (\x -> case x of {p -> True; _ -> False}) e +-- in +-- <<[:e' | qs:]>> (pa, p) (crossP ea ef) +-- +dePArrComp (BindStmt p e _ : qs) pa cea = + dsLookupGlobalValue falseDataConName `thenDs` \falseId -> + dsLookupGlobalValue trueDataConName `thenDs` \trueId -> + dsLookupGlobalValue filterPName `thenDs` \filterP -> + dsLookupGlobalValue crossPName `thenDs` \crossP -> + dsExpr e `thenDs` \ce -> + let ty'cea = parrElemType cea + ty'ce = parrElemType ce + false = Var falseId + true = Var trueId + in + newSysLocalDs ty'ce `thenDs` \v -> + matchSimply (Var v) (DoCtxt PArrComp) p true false `thenDs` \pred -> + let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce] + ty'cef = ty'ce -- filterP preserves the type + pa' = TuplePat [pa, p] Boxed + in + dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef]) +-- +-- <<[:e' | let ds, qs:]>> pa ea = +-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) +-- (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea) +-- where +-- {x_1, ..., x_n} = DV (ds) -- Defined Variables +-- +dePArrComp (LetStmt ds : qs) pa cea = + dsLookupGlobalValue mapPName `thenDs` \mapP -> + let xs = collectHsOutBinders ds + ty'cea = parrElemType cea + in + newSysLocalDs ty'cea `thenDs` \v -> + dsLet ds (mkTupleExpr xs) `thenDs` \clet -> + newSysLocalDs (exprType clet) `thenDs` \let'v -> + let projBody = mkDsLet (NonRec let'v clet) $ mkTupleExpr [v, let'v] + errTy = exprType projBody + errMsg = "DsListComp.dePArrComp: internal error!" + in + mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> + matchSimply (Var v) (DoCtxt PArrComp) pa projBody cerr `thenDs` \ccase -> + let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed + proj = mkLams [v] ccase + in + dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea]) +-- +-- <<[:e' | qs | qss:]>> pa ea = +-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) +-- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) +-- where +-- {x_1, ..., x_n} = DV (qs) +-- +dePArrComp (ParStmtOut [] : qss2) pa cea = dePArrComp qss2 pa cea +dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea = + dsLookupGlobalValue zipPName `thenDs` \zipP -> + let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed + ty'cea = parrElemType cea + resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc + in + dsPArrComp (qs ++ [resStmt]) undefined `thenDs` \cqs -> + let ty'cqs = parrElemType cqs + cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] + in + dePArrComp (ParStmtOut qss : qss2) pa' cea' + +-- generate Core corresponding to `\p -> e' +-- +deLambda :: Type -- type of the argument + -> TypecheckedPat -- argument pattern + -> TypecheckedHsExpr -- body + -> DsM (CoreExpr, Type) +deLambda ty p e = + newSysLocalDs ty `thenDs` \v -> + dsExpr e `thenDs` \ce -> + let errTy = exprType ce + errMsg = "DsListComp.deLambda: internal error!" + in + mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> + matchSimply (Var v) (DoCtxt PArrComp) p ce cerr `thenDs` \res -> + returnDs (mkLams [v] res, errTy) + +-- obtain the element type of the parallel array produced by the given Core +-- expression +-- +parrElemType :: CoreExpr -> Type +parrElemType e = + case splitTyConApp_maybe (exprType e) of + Just (tycon, [ty]) | tyConName tycon == parrTyConName -> ty + _ -> panic + "DsListComp.parrElemType: not a parallel array type" +\end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 6b45c58..9bb99a6 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -44,23 +44,24 @@ import MkId ( rebuildConArgs ) import Id ( idType, Id, mkWildId ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon ) -import DataCon ( DataCon, dataConStrictMarks, dataConId ) -import Type ( mkFunTy, isUnLiftedType, Type ) +import DataCon ( DataCon, dataConStrictMarks, dataConId, + dataConSourceArity ) +import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp ) import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy ) import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, unitDataConId, unitTy, charTy, charDataCon, - intDataCon, smallIntegerDataCon, + intTy, intDataCon, smallIntegerDataCon, floatDataCon, doubleDataCon, - stringTy - ) + stringTy, isPArrFakeCon ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name, - plusIntegerName, timesIntegerName ) + plusIntegerName, timesIntegerName, + lengthPName, indexPName ) import Outputable import UnicodeUtil ( stringToUtf8 ) import Util ( isSingleton ) @@ -265,6 +266,9 @@ mkCoAlgCaseMatchResult var match_alts = ASSERT( null (tail match_alts) && null (tail arg_ids) ) mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result + | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case + = MatchResult CanFail mk_parrCase + | otherwise -- Datatype case; use a case = MatchResult fail_flag mk_case where @@ -309,6 +313,72 @@ mkCoAlgCaseMatchResult var match_alts un_mentioned_constructors = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] exhaustive_case = isEmptyUniqSet un_mentioned_constructors + + -- Stuff for parallel arrays + -- + -- * the following is to desugar cases over fake constructors for + -- parallel arrays, which are introduced by `tidy1' in the `PArrPat' + -- case + -- + -- Concerning `isPArrFakeAlts': + -- + -- * it is *not* sufficient to just check the type of the type + -- constructor, as we have to be careful not to confuse the real + -- representation of parallel arrays with the fake constructors; + -- moreover, a list of alternatives must not mix fake and real + -- constructors (this is checked earlier on) + -- + -- FIXME: We actually go through the whole list and make sure that + -- either all or none of the constructors are fake parallel + -- array constructors. This is to spot equations that mix fake + -- constructors with the real representation defined in + -- `PrelPArr'. It would be nicer to spot this situation + -- earlier and raise a proper error message, but it can really + -- only happen in `PrelPArr' anyway. + -- + isPArrFakeAlts [(dcon, _, _)] = isPArrFakeCon dcon + isPArrFakeAlts ((dcon, _, _):alts) = + case (isPArrFakeCon dcon, isPArrFakeAlts alts) of + (True , True ) -> True + (False, False) -> False + _ -> + panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns" + -- + mk_parrCase fail = + dsLookupGlobalValue lengthPName `thenDs` \lengthP -> + unboxAlt `thenDs` \alt -> + returnDs (Case (len lengthP) (mkWildId intTy) [alt]) + where + elemTy = case splitTyConApp (idType var) of + (_, [elemTy]) -> elemTy + _ -> panic panicMsg + panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?" + len lengthP = mkApps (Var lengthP) [Type elemTy, Var var] + -- + unboxAlt = + newSysLocalDs intPrimTy `thenDs` \l -> + dsLookupGlobalValue indexPName `thenDs` \indexP -> + mapDs (mkAlt indexP) match_alts `thenDs` \alts -> + returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) + where + wild = mkWildId intPrimTy + dft = (DEFAULT, [], fail) + -- + -- each alternative matches one array length (corresponding to one + -- fake array constructor), so the match is on a literal; each + -- alternative's body is extended by a local binding for each + -- constructor argument, which are bound to array elements starting + -- with the first + -- + mkAlt indexP (con, args, MatchResult _ bodyFun) = + bodyFun fail `thenDs` \body -> + returnDs (LitAlt lit, [], mkDsLets binds body) + where + lit = MachInt $ toInteger (dataConSourceArity con) + binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] + -- + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i] + toInt i = mkConApp intDataCon [Lit $ MachInt i] \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 74be345..1f9fcda 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -24,7 +24,8 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon ) +import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, + tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import UniqSet import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) @@ -314,7 +315,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. \item Removing lazy (irrefutable) patterns (you don't want to know...). \item -Converting explicit tuple- and list-pats into ordinary @ConPats@. +Converting explicit tuple-, list-, and parallel-array-pats into ordinary +@ConPats@. \item Convert the literal pat "" to []. \end{itemize} @@ -441,6 +443,15 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats +-- introduce fake parallel array constructors to be able to handle parallel +-- arrays with the existing machinery for constructor pattern +-- +tidy1 v (PArrPat ty pats) match_result + = returnDs (parrConPat, match_result) + where + arity = length pats + parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats + tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 91ddad3..419cb31 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -101,6 +101,10 @@ data HsExpr id pat PostTcType -- Gives type of components of list [HsExpr id pat] + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array + [HsExpr id pat] + | ExplicitTuple -- tuple [HsExpr id pat] -- NB: Unit is ExplicitTuple [] @@ -137,6 +141,11 @@ data HsExpr id pat | ArithSeqOut (HsExpr id pat) -- (typechecked, of course) (ArithSeqInfo id pat) + | PArrSeqIn -- arith. sequence for parallel array + (ArithSeqInfo id pat) -- [:e1..e2:] or [:e1, e2..e3:] + | PArrSeqOut + (HsExpr id pat) -- (typechecked, of course) + (ArithSeqInfo id pat) | HsCCall CLabelString -- call into the C world; string is [HsExpr id pat] -- the C function; exprs are the @@ -305,6 +314,9 @@ ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) = brackets (fsep (punctuate comma (map ppr_expr exprs))) +ppr_expr (ExplicitPArr _ exprs) + = pabrackets (fsep (punctuate comma (map ppr_expr exprs))) + ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) @@ -327,6 +339,11 @@ ppr_expr (ArithSeqIn info) ppr_expr (ArithSeqOut expr info) = brackets (ppr info) +ppr_expr (PArrSeqIn info) + = pabrackets (ppr info) +ppr_expr (PArrSeqOut expr info) + = pabrackets (ppr info) + ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e @@ -363,7 +380,11 @@ ppr_expr (DictApp expr dnames) 4 (brackets (interpp'SP dnames)) ppr_expr (HsType id) = ppr id - + +-- add parallel array brackets around a document +-- +pabrackets :: SDoc -> SDoc +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} Parenthesize unless very simple: @@ -382,6 +403,7 @@ pprParendExpr expr HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was ExplicitTuple _ _ -> pp_as_was HsPar _ -> pp_as_was @@ -589,6 +611,7 @@ depends on the context. Consider the following contexts: E :: rhs_ty Translation: E +Array comprehensions are handled like list comprehensions -=chak \begin{code} consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] @@ -610,14 +633,20 @@ pprStmt (ParStmt stmtss) pprStmt (ParStmtOut stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) -pprDo :: (Outputable id, Outputable pat) => HsDoContext -> [Stmt id pat] -> SDoc +pprDo :: (Outputable id, Outputable pat) + => HsDoContext -> [Stmt id pat] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) -pprDo ListComp stmts = brackets $ - hang (pprExpr expr <+> char '|') - 4 (interpp'SP quals) - where - ResultStmt expr _ = last stmts -- Last stmt should - quals = init stmts -- be an ResultStmt +pprDo ListComp stmts = pprComp brackets stmts +pprDo PArrComp stmts = pprComp pabrackets stmts + +pprComp :: (Outputable id, Outputable pat) + => (SDoc -> SDoc) -> [Stmt id pat] -> SDoc +pprComp brack stmts = brack $ + hang (pprExpr expr <+> char '|') + 4 (interpp'SP quals) + where + ResultStmt expr _ = last stmts -- Last stmt should + quals = init stmts -- be an ResultStmt \end{code} %************************************************************************ @@ -667,7 +696,9 @@ data HsMatchContext id -- Context of a Match or Stmt | RecUpd -- Record update deriving () -data HsDoContext = ListComp | DoExpr +data HsDoContext = ListComp + | DoExpr + | PArrComp -- parallel array comprehension \end{code} \begin{code} @@ -691,7 +722,10 @@ pprMatchContext RecUpd = ptext SLIT("In a record-update construct") pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding") pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction") pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding") -pprMatchContext (DoCtxt ListComp) = ptext SLIT("In a 'list comprehension' pattern binding") +pprMatchContext (DoCtxt ListComp) = + ptext SLIT("In a 'list comprehension' pattern binding") +pprMatchContext (DoCtxt PArrComp) = + ptext SLIT("In an 'array comprehension' pattern binding") -- Used to generate the string for a *runtime* error message matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) @@ -701,4 +735,5 @@ matchContextErrString RecUpd = "record update" matchContextErrString LambdaExpr = "lambda" matchContextErrString (DoCtxt DoExpr) = "'do' expression" matchContextErrString (DoCtxt ListComp) = "list comprehension" +matchContextErrString (DoCtxt PArrComp) = "array comprehension" \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 00df779..c801a86 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -12,7 +12,7 @@ module HsPat ( failureFreePat, isWildPat, patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - collectPatBinders, collectPatsBinders, + collectPatBinders, collectOutPatBinders, collectPatsBinders, collectSigTysFromPat, collectSigTysFromPats ) where @@ -66,6 +66,8 @@ data InPat name | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements + | PArrPatIn [InPat name] -- syntactic parallel array + -- must have >= 1 elements | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record @@ -96,6 +98,9 @@ data OutPat id | ListPat -- Syntactic list Type -- The type of the elements [OutPat id] + | PArrPat -- Syntactic parallel array + Type -- The type of the elements + [OutPat id] | TuplePat [OutPat id] -- Tuple Boxity @@ -158,6 +163,7 @@ pprInPat (LazyPatIn pat) = char '~' <> ppr pat pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) pprInPat (ParPatIn pat) = parens (pprInPat pat) pprInPat (ListPatIn pats) = brackets (interpp'SP pats) +pprInPat (PArrPatIn pats) = pabrackets (interpp'SP pats) pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) pprInPat (NPatIn l) = ppr l @@ -179,6 +185,11 @@ pprInPat (RecPatIn con rpats) pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") + +-- add parallel array brackets around a document +-- +pabrackets :: SDoc -> SDoc +pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} \begin{code} @@ -210,6 +221,7 @@ pprOutPat (ConPat name ty tyvars dicts pats) _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) +pprOutPat (PArrPat ty pats) = pabrackets (interpp'SP pats) pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats) pprOutPat (RecPat con ty tvs dicts rpats) @@ -278,6 +290,7 @@ failureFreePat (AsPat _ pat) = failureFreePat pat failureFreePat (ConPat con tys _ _ pats) = only_con con && all failureFreePat pats failureFreePat (RecPat con _ _ _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ] failureFreePat (ListPat _ _) = False +failureFreePat (PArrPat _ _) = False failureFreePat (TuplePat pats _) = all failureFreePat pats failureFreePat (DictPat _ _) = True failureFreePat other_pat = False -- Literals, NPat @@ -295,6 +308,7 @@ patsAreAllCons pat_list = all isConPat pat_list isConPat (AsPat _ pat) = isConPat pat isConPat (ConPat _ _ _ _ _) = True isConPat (ListPat _ _) = True +isConPat (PArrPat _ _) = True isConPat (TuplePat _ _) = True isConPat (RecPat _ _ _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 @@ -318,6 +332,9 @@ collected is important; see @HsBinds.lhs@. collectPatBinders :: InPat a -> [a] collectPatBinders pat = collect pat [] +collectOutPatBinders :: OutPat a -> [a] +collectOutPatBinders pat = collectOut pat [] + collectPatsBinders :: [InPat a] -> [a] collectPatsBinders pats = foldr collect [] pats @@ -333,11 +350,31 @@ collect (ConPatIn c pats) bndrs = foldr collect bndrs pats collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) collect (ParPatIn pat) bndrs = collect pat bndrs collect (ListPatIn pats) bndrs = foldr collect bndrs pats +collect (PArrPatIn pats) bndrs = foldr collect bndrs pats collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields -- Generics collect (TypePatIn ty) bndrs = bndrs -- assume the type variables do not need to be bound + +-- collect the bounds *value* variables in renamed patterns; type variables +-- are *not* collected +-- +collectOut (WildPat _) bndrs = bndrs +collectOut (VarPat var) bndrs = var : bndrs +collectOut (LazyPat pat) bndrs = collectOut pat bndrs +collectOut (AsPat a pat) bndrs = a : collectOut pat bndrs +collectOut (ListPat _ pats) bndrs = foldr collectOut bndrs pats +collectOut (PArrPat _ pats) bndrs = foldr collectOut bndrs pats +collectOut (TuplePat pats _) bndrs = foldr collectOut bndrs pats +collectOut (ConPat _ _ _ ds pats) bndrs = ds ++ foldr collectOut bndrs pats +collectOut (RecPat _ _ _ ds fields) bndrs = ds ++ foldr comb bndrs fields + where + comb (_, pat, _) bndrs = collectOut pat bndrs +collectOut (LitPat _ _) bndrs = bndrs +collectOut (NPat _ _ _) bndrs = bndrs +collectOut (NPlusKPat n _ _ _ _) bndrs = n : bndrs +collectOut (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs \end{code} \begin{code} @@ -359,6 +396,7 @@ collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) collect_pat (ParPatIn pat) acc = collect_pat pat acc collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats +collect_pat (PArrPatIn pats) acc = foldr collect_pat acc pats collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields -- Generics diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index cb42ba5..6a393cf 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -23,7 +23,7 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - collectHsBinders, collectLocatedHsBinders, + collectHsBinders, collectHsOutBinders, collectLocatedHsBinders, collectMonoBinders, collectLocatedMonoBinders, collectSigTysFromMonoBinds, hsModuleName, hsModuleImports @@ -132,6 +132,15 @@ collectHsBinders (MonoBind b _ _) collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2 +-- corresponds to `collectHsBinders', but operates on renamed patterns +-- +collectHsOutBinders :: HsBinds name (OutPat name) -> [name] +collectHsOutBinders EmptyBinds = [] +collectHsOutBinders (MonoBind b _ _) + = collectMonoOutBinders b +collectHsOutBinders (ThenBinds b1 b2) + = collectHsOutBinders b1 ++ collectHsOutBinders b2 + collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)] collectLocatedMonoBinders binds = go binds [] @@ -149,6 +158,17 @@ collectMonoBinders binds go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc go (FunMonoBind f _ _ loc) acc = f : acc go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) + +-- corresponds to `collectMonoBinders', but operates on renamed patterns +-- +collectMonoOutBinders :: MonoBinds name (OutPat name) -> [name] +collectMonoOutBinders binds + = go binds [] + where + go EmptyMonoBinds acc = acc + go (PatMonoBind pat _ loc) acc = collectOutPatBinders pat ++ acc + go (FunMonoBind f _ _ loc) acc = f : acc + go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 5e9b874..acdf8fd 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -43,9 +43,9 @@ import Var ( TyVar, tyVarKind ) import Subst ( substTyWith ) import PprType ( {- instance Outputable Kind -}, pprParendKind ) import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) -import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, - usOnceTyConName, usManyTyConName - ) +import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey, + usOnceTyConKey, usManyTyConKey, hasKey, + usOnceTyConName, usManyTyConName ) import FiniteMap import Util ( eqListBy, lengthIs ) import Outputable @@ -98,6 +98,8 @@ data HsType name | HsListTy (HsType name) -- Element type + | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] + | HsTupleTy (HsTupCon name) [HsType name] -- Element types (length gives arity) -- Generics @@ -275,6 +277,9 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) + where + pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen (ctxt_prec >= pREC_CON) @@ -344,6 +349,7 @@ toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of | not saturated = generic_case | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys' | tc `hasKey` listTyConKey = HsListTy (head tys') + | tc `hasKey` parrTyConKey = HsPArrTy (head tys') | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified | tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified | otherwise = generic_case @@ -449,6 +455,9 @@ eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) eq_hsType env (HsListTy ty1) (HsListTy ty2) = eq_hsType env ty1 ty2 +eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2) + = eq_hsType env ty1 ty2 + eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2) = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index e19c24a..ea6ea71 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -67,6 +67,7 @@ module CmdLineOpts ( opt_Parallel, opt_SMP, opt_RuntimeTypes, + opt_Flatten, -- optimisation opts opt_NoMethodSharing, @@ -255,6 +256,7 @@ data DynFlag | Opt_D_dump_simpl_stats | Opt_D_dump_tc_trace | Opt_D_dump_BCOs + | Opt_D_dump_vect | Opt_D_source_stats | Opt_D_verbose_core2core | Opt_D_verbose_stg2stg @@ -287,6 +289,7 @@ data DynFlag | Opt_AllowIncoherentInstances | Opt_NoMonomorphismRestriction | Opt_GlasgowExts + | Opt_PArr -- syntactic support for parallel arrays | Opt_Generics | Opt_NoImplicitPrelude @@ -565,6 +568,7 @@ opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDU opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_Parallel = lookUp SLIT("-fparallel") opt_SMP = lookUp SLIT("-fsmp") +opt_Flatten = lookUp SLIT("-fflatten") -- optimisation opts opt_NoMethodSharing = lookUp SLIT("-fno-method-sharing") @@ -645,6 +649,7 @@ isStaticHscFlag f = "fnumbers-strict", "fparallel", "fsmp", + "fflatten", "fsemi-tagging", "ffoldr-build-on", "flet-no-escape", diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index a507e8f..bfb3c00 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.85 2002/01/25 10:28:14 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.86 2002/02/11 08:20:41 chak Exp $ -- -- Driver flags -- @@ -198,6 +198,7 @@ static_flags = , ( "gransim" , NoArg (addNoDups v_Ways WayGran) ) , ( "smp" , NoArg (addNoDups v_Ways WaySMP) ) , ( "debug" , NoArg (addNoDups v_Ways WayDebug) ) + , ( "ndp" , NoArg (addNoDups v_Ways WayNDP) ) -- ToDo: user ways ------ Debugging ---------------------------------------------------- @@ -393,6 +394,7 @@ dynamic_flags = [ , ( "ddump-hi-diffs", NoArg (setDynFlag Opt_D_dump_hi_diffs) ) , ( "ddump-hi", NoArg (setDynFlag Opt_D_dump_hi) ) , ( "ddump-minimal-imports", NoArg (setDynFlag Opt_D_dump_minimal_imports) ) + , ( "ddump-vect", NoArg (setDynFlag Opt_D_dump_vect) ) , ( "dcore-lint", NoArg (setDynFlag Opt_DoCoreLinting) ) , ( "dstg-lint", NoArg (setDynFlag Opt_DoStgLinting) ) , ( "dusagesp-lint", NoArg (setDynFlag Opt_DoUSPLinting) ) @@ -444,6 +446,7 @@ fFlags = [ ( "warn-unused-matches", Opt_WarnUnusedMatches ), ( "warn-deprecations", Opt_WarnDeprecations ), ( "glasgow-exts", Opt_GlasgowExts ), + ( "parr", Opt_PArr ), ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 2daa817..39934b9 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.66 2002/01/04 16:02:04 simonmar Exp $ +-- $Id: DriverState.hs,v 1.67 2002/02/11 08:20:41 chak Exp $ -- -- Settings for the driver -- @@ -573,6 +573,7 @@ data WayName | WayPar | WayGran | WaySMP + | WayNDP | WayDebug | WayUser_a | WayUser_b @@ -598,7 +599,9 @@ GLOBAL_VAR(v_Ways, [] ,[WayName]) allowed_combination way = way `elem` combs where -- the sub-lists must be ordered according to WayName, -- because findBuildTag sorts them - combs = [ [WayProf,WayUnreg], [WayProf,WaySMP] ] + combs = [ [WayProf, WayUnreg], + [WayProf, WaySMP] , + [WayProf, WayNDP] ] findBuildTag :: IO [String] -- new options findBuildTag = do @@ -703,6 +706,10 @@ way_details = , "-optc-DSMP" , "-fvia-C" ]), + (WayNDP, Way "ndp" "Nested data parallelism" + [ "-fparr" + , "-fflatten"]), + (WayUser_a, Way "a" "User way 'a'" ["$WAY_a_REAL_OPTS"]), (WayUser_b, Way "b" "User way 'b'" ["$WAY_b_REAL_OPTS"]), (WayUser_c, Way "c" "User way 'c'" ["$WAY_c_REAL_OPTS"]), diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 9a8e23f..5267fba 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -45,7 +45,7 @@ import Id ( idName ) import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) import StringBuffer ( hGetStringBuffer, freeStringBuffer ) import Parser -import Lex ( PState(..), ParseResult(..) ) +import Lex ( PState(..), ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) import Finder ( findModule ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) @@ -57,6 +57,7 @@ import MkIface ( mkFinalIface ) import TcModule import InstEnv ( emptyInstEnv ) import Desugar +import Flattening ( flatten, flattenExpr ) import SimplCore import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) @@ -245,6 +246,13 @@ hscRecomp ghci_mode dflags have_object <- _scc_ "DeSugar" deSugar dflags pcs_tc hst this_mod print_unqual tc_result + ------------------- + -- FLATTENING + ------------------- + ; flat_details + <- _scc_ "Flattening" + flatten dflags pcs_tc hst ds_details + ; pcs_middle <- _scc_ "pcs_middle" if ghci_mode == OneShot @@ -271,7 +279,7 @@ hscRecomp ghci_mode dflags have_object ------------------- ; simpl_details <- _scc_ "Core2Core" - core2core dflags pcs_middle hst dont_discard ds_details + core2core dflags pcs_middle hst dont_discard flat_details ------------------- -- TIDY @@ -411,12 +419,11 @@ myParseModule dflags src_filename buf <- hGetStringBuffer True{-expand tabs-} src_filename - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc (_PK_ src_filename) 1 - case parseModule buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc (_PK_ src_filename) 1 } of { + case parseModule buf (mkPState loc exts) of { PFailed err -> do { hPutStrLn stderr (showSDoc err); freeStringBuffer buf; @@ -549,8 +556,11 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr -- Desugar it ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr + -- Flatten it + ; flat_expr <- flattenExpr dflags pcs2 hst ds_expr + -- Simplify it - ; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr + ; simpl_expr <- simplifyExpr dflags pcs2 hst flat_expr -- Tidy it (temporary, until coreSat does cloning) ; tidy_expr <- tidyCoreExpr simpl_expr @@ -582,12 +592,11 @@ hscParseStmt dflags str buf <- stringToStringBuffer str - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc SLIT("") 1 - case parseStmt buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc SLIT("") 1 } of { + case parseStmt buf (mkPState loc exts) of { PFailed err -> do { hPutStrLn stderr (showSDoc err); -- Not yet implemented in <4.11 freeStringBuffer buf; @@ -667,13 +676,11 @@ hscThing dflags hst hit pcs0 ic str myParseIdentifier dflags str = do buf <- stringToStringBuffer str - let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, + parrEF = dopt Opt_PArr dflags} + loc = mkSrcLoc SLIT("") 1 - case parseIdentifier buf - PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = glaexts, - loc = mkSrcLoc SLIT("") 1 } of + case parseIdentifier buf (mkPState loc exts) of PFailed err -> do { hPutStrLn stderr (showSDoc err); freeStringBuffer buf; diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index cae45bc..c6e6580 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -81,9 +81,10 @@ happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc) loadPackageConfig :: FilePath -> IO [PackageConfig] loadPackageConfig conf_filename = do buf <- hGetStringBuffer False conf_filename - case parse buf PState{ bol = 0#, atbol = 1#, - context = [], glasgow_exts = 0#, - loc = mkSrcLoc (_PK_ conf_filename) 1 } of + let loc = mkSrcLoc (_PK_ conf_filename) 1 + exts = ExtFlags {glasgowExtsEF = False, + parrEF = False} + case parse buf (mkPState loc exts) of PFailed err -> do freeStringBuffer buf throwDyn (InstallationError (showSDoc err)) diff --git a/ghc/compiler/ndpFlatten/FlattenInfo.hs b/ghc/compiler/ndpFlatten/FlattenInfo.hs new file mode 100644 index 0000000..4a08c69 --- /dev/null +++ b/ghc/compiler/ndpFlatten/FlattenInfo.hs @@ -0,0 +1,43 @@ +-- $Id$ +-- +-- Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller +-- +-- Information for modules outside of the flattening module collection. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module contains information that is needed, and thus imported, by +-- modules that are otherwise independent of flattening and may in fact be +-- directly or indirectly imported by some of the flattening-related +-- modules. This is to avoid cyclic module dependencies. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +--- TODO ---------------------------------------------------------------------- +-- + +module FlattenInfo ( + namesNeededForFlattening +) where + +import CmdLineOpts (opt_Flatten) +import NameSet (FreeVars, emptyFVs, mkFVs) +import PrelNames (fstName, andName, orName, lengthPName, replicatePName, + mapPName, bpermutePName, bpermuteDftPName, indexOfPName) + + +-- this is a list of names that need to be available if flattening is +-- performed (EXPORTED) +-- +-- * needs to be kept in sync with the names used in Core generation in +-- `FlattenMonad' and `NDPCoreUtils' +-- +namesNeededForFlattening :: FreeVars +namesNeededForFlattening + | not opt_Flatten = emptyFVs -- none without -fflatten + | otherwise = mkFVs + [fstName, andName, orName, lengthPName, replicatePName, mapPName, + bpermutePName, bpermuteDftPName, indexOfPName] + -- stuff from PrelGHC doesn't have to go here diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs new file mode 100644 index 0000000..1a6955e --- /dev/null +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -0,0 +1,454 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Monad maintaining parallel contexts and substitutions for flattening. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- The flattening transformation needs to perform a fair amount of plumbing. +-- It needs to mainatin a set of variables, called the parallel context for +-- lifting, variable substitutions in case alternatives, and so on. +-- Moreover, we need to manage uniques to create new variables. The monad +-- defined in this module takes care of maintaining this state. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +-- * a parallel context is a set of variables that get vectorised during a +-- lifting transformations (ie, their type changes from `t' to `[:t:]') +-- +-- * all vectorised variables in a parallel context have the same size; we +-- call this also the size of the parallel context +-- +-- * we represent contexts by maps that give the lifted version of a variable +-- (remember that in GHC, variables contain type information that changes +-- during lifting) +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * Assumptions currently made that should (if they turn out to be true) be +-- documented in The Commentary: +-- +-- - Local bindings can be copied without any need to alpha-rename bound +-- variables (or their uniques). Such renaming is only necessary when +-- bindings in a recursive group are replicated; implying that this is +-- required in the case of top-level bindings). (Note: The CoreTidy path +-- generates global uniques before code generation.) +-- +-- * One FIXME left to resolve. +-- + +module FlattenMonad ( + + -- monad definition + -- + Flatten, runFlatten, + + -- variable generation + -- + newVar, mkBind, + + -- context management & query operations + -- + extendContext, packContext, liftVar, liftConst, intersectWithContext, + + -- construction of prelude functions + -- + mk'fst, mk'eq, mk'neq, mk'and, mk'or, mk'lengthP, mk'replicateP, mk'mapP, + mk'bpermuteP, mk'bpermuteDftP, mk'indexOfP +) where + +-- standard +import Monad (mplus) + +-- GHC +import CmdLineOpts (opt_Flatten) +import Panic (panic) +import Outputable (Outputable(ppr), pprPanic) +import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply) +import OccName (UserFS) +import Var (Var(..)) +import Id (Id, mkSysLocal) +import Name (Name) +import VarSet (VarSet, emptyVarSet, unitVarSet, extendVarSet, + varSetElems, unionVarSet) +import VarEnv (VarEnv, emptyVarEnv, unitVarEnv, zipVarEnv, plusVarEnv, + elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) +import TyCon (tyConName) +import Type (Type, tyConAppTyCon) +import HscTypes (HomeSymbolTable, PersistentCompilerState(..), + TyThing(..), lookupType) +import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName, + doublePrimTyConName, fstName, andName, orName, + eqCharName, eqIntName, eqFloatName, eqDoubleName, + neqCharName, neqIntName, neqFloatName, neqDoubleName, + lengthPName, replicatePName, mapPName, bpermutePName, + bpermuteDftPName, indexOfPName) +import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps, + bindersOfBinds) +import CoreUtils (exprType) + +-- friends +import NDPCoreUtils (parrElemTy) + + +-- definition of the monad +-- ----------------------- + +-- state maintained by the flattening monad +-- +data FlattenState = FlattenState { + + -- our source for uniques + -- + us :: UniqSupply, + + -- environment containing all known names (including all + -- Prelude functions) + -- + env :: Name -> Id, + + -- this variable determines the parallel context; if + -- `Nothing', we are in pure vectorisation mode, no + -- lifting going on + -- + ctxtVar :: Maybe Var, + + -- environment that maps each variable that is + -- vectorised in the current parallel context to the + -- vectorised version of that variable + -- + ctxtEnv :: VarEnv Var, + + -- those variables from the *domain* of `ctxtEnv' that + -- have been used since the last context restriction (cf. + -- `restrictContext') + -- + usedVars :: VarSet + } + +-- initial value of the flattening state +-- +initialFlattenState :: PersistentCompilerState + -> HomeSymbolTable + -> UniqSupply + -> FlattenState +initialFlattenState pcs hst us = + FlattenState { + us = us, + env = lookup, + ctxtVar = Nothing, + ctxtEnv = emptyVarEnv, + usedVars = emptyVarSet + } + where + lookup n = + case lookupType hst (pcs_PTE pcs) n of + Just (AnId v) -> v + _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) + +-- the monad representation (EXPORTED ABSTRACTLY) +-- +newtype Flatten a = Flatten { + unFlatten :: (FlattenState -> (a, FlattenState)) + } + +instance Monad Flatten where + return x = Flatten $ \s -> (x, s) + m >>= n = Flatten $ \s -> let + (r, s') = unFlatten m s + in + unFlatten (n r) s' + +-- execute the given flattening computation (EXPORTED) +-- +runFlatten :: PersistentCompilerState + -> HomeSymbolTable + -> UniqSupply + -> Flatten a + -> a +runFlatten pcs hst us m = fst $ unFlatten m (initialFlattenState pcs hst us) + + +-- variable generation +-- ------------------- + +-- generate a new local variable whose name is based on the given lexeme and +-- whose type is as specified in the second argument (EXPORTED) +-- +newVar :: UserFS -> Type -> Flatten Var +newVar lexeme ty = Flatten $ \state -> + let + (us1, us2) = splitUniqSupply (us state) + state' = state {us = us2} + in + (mkSysLocal lexeme (uniqFromSupply us1) ty, state') + +-- generate a non-recursive binding using a new binder whose name is derived +-- from the given lexeme (EXPORTED) +-- +mkBind :: UserFS -> CoreExpr -> Flatten (CoreBndr, CoreBind) +mkBind lexeme e = + do + v <- newVar lexeme (exprType e) + return (v, NonRec v e) + + +-- context management +-- ------------------ + +-- extend the parallel context by the given set of variables (EXPORTED) +-- +-- * if there is no parallel context at the moment, the first element of the +-- variable list will be used to determine the new parallel context +-- +-- * the second argument is executed in the current context extended with the +-- given variables +-- +-- * the variables must already have been lifted by transforming their type, +-- but they *must* have retained their original name (or, at least, their +-- unique); this is needed so that they match the original variable in +-- variable environments +-- +-- * any trace of the given set of variables has to be removed from the state +-- at the end of this operation +-- +extendContext :: [Var] -> Flatten a -> Flatten a +extendContext [] m = m +extendContext vs m = Flatten $ \state -> + let + extState = state { + ctxtVar = ctxtVar state `mplus` Just (head vs), + ctxtEnv = ctxtEnv state `plusVarEnv` zipVarEnv vs vs + } + (r, extState') = unFlatten m extState + resState = extState' { -- remove `vs' from the result state + ctxtVar = ctxtVar state, + ctxtEnv = ctxtEnv state, + usedVars = usedVars extState' `delVarEnvList` vs + } + in + (r, resState) + +-- execute the second argument in a restricted context (EXPORTED) +-- +-- * all variables in the current parallel context are packed according to +-- the permutation vector associated with the variable passed as the first +-- argument (ie, all elements of vectorised context variables that are +-- invalid in the restricted context are dropped) +-- +-- * the returned list of core binders contains the operations that perform +-- the restriction on all variables in the parallel context that *do* occur +-- during the execution of the second argument (ie, `liftVar' is executed at +-- least once on any such variable) +-- +packContext :: Var -> Flatten a -> Flatten (a, [CoreBind]) +packContext perm m = Flatten $ \state -> + let + -- FIXME: To set the packed environment to the unpacked on is a hack of + -- which I am not sure yet (a) whether it works and (b) whether it's + -- really worth it. The one advantages is that, we can use a var set, + -- after all, instead of a var environment. + -- + -- The idea is the following: If we have to pack a variable `x', we + -- generate `let{-NonRec-} x = bpermuteP perm x in ...'. As this is a + -- non-recursive binding, the lhs `x' overshadows the rhs `x' in the + -- body of the let. + -- + -- NB: If we leave it like this, `mkCoreBind' can be simplified. + packedCtxtEnv = ctxtEnv state + packedState = state { + ctxtVar = fmap + (lookupVarEnv_NF packedCtxtEnv) + (ctxtVar state), + ctxtEnv = packedCtxtEnv, + usedVars = emptyVarSet + } + (r, packedState') = unFlatten m packedState + resState = state { -- revert to the unpacked context + ctxtVar = ctxtVar state, + ctxtEnv = ctxtEnv state, + } + bndrs = map mkCoreBind . varSetElems . usedVars $ packedState' + + -- generate a binding for the packed variant of a context variable + -- + mkCoreBind var = let + rhs = fst $ unFlatten (mk'bpermuteP (varType var) + (Var perm) + (Var var) + ) state + in + NonRec (lookupVarEnv_NF packedCtxtEnv var) $ rhs + + in + ((r, bndrs), resState) + +-- lift a single variable in the current context (EXPORTED) +-- +-- * if the variable does not occur in the context, it's value is vectorised to +-- match the size of the current context +-- +-- * otherwise, the variable is replaced by whatever the context environment +-- maps it to (this may either be simply the lifted version of the original +-- variable or a packed variant of that variable) +-- +-- * the monad keeps track of all lifted variables that occur in the parallel +-- context, so that `packContext' can determine the correct set of core +-- bindings +-- +liftVar :: Var -> Flatten CoreExpr +liftVar var = Flatten $ \s -> + let + v = ctxtVarErr s + v'elemType = parrElemTy . varType $ v + len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s + replicated = fst $ unFlatten (mk'replicateP (varType var) len (Var var)) s + in case lookupVarEnv (ctxtEnv s) var of + Just liftedVar -> (Var liftedVar, + s {usedVars = usedVars s `extendVarSet` var}) + Nothing -> (replicated, s) + +-- lift a constant expression in the current context (EXPORTED) +-- +-- * the value of the constant expression is vectorised to match the current +-- parallel context +-- +liftConst :: CoreExpr -> Flatten CoreExpr +liftConst e = Flatten $ \s -> + let + v = ctxtVarErr s + v'elemType = parrElemTy . varType $ v + len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s + in + (fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s) + +-- pick those variables of the given set that occur (if albeit in lifted form) +-- in the current parallel context (EXPORTED) +-- +-- * the variables returned are from the given set and *not* the corresponding +-- context variables +-- +intersectWithContext :: VarSet -> Flatten [Var] +intersectWithContext vs = Flatten $ \s -> + let + vs' = filter (`elemVarEnv` ctxtEnv s) (varSetElems vs) + in + (vs', s) + + +-- construct applications of prelude functions +-- ------------------------------------------- + +-- NB: keep all the used names listed in `FlattenInfo.namesNeededForFlattening' + +-- generate an application of `fst' (EXPORTED) +-- +mk'fst :: Type -> Type -> CoreExpr -> Flatten CoreExpr +mk'fst ty1 ty2 a = mkFunApp fstName [Type ty1, Type ty2, a] + +-- generate an application of `&&' (EXPORTED) +-- +mk'and :: CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'and a1 a2 = mkFunApp andName [a1, a2] + +-- generate an application of `||' (EXPORTED) +-- +mk'or :: CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'or a1 a2 = mkFunApp orName [a1, a2] + +-- generate an application of `==' where the arguments may only be literals +-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and +-- `Double') (EXPORTED) +-- +mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'eq ty a1 a2 = mkFunApp eqName [a1, a2] + where + name = tyConName . tyConAppTyCon $ ty + -- + eqName | name == charPrimTyConName = eqCharName + | name == intPrimTyConName = eqIntName + | name == floatPrimTyConName = eqFloatName + | name == doublePrimTyConName = eqDoubleName + | otherwise = + pprPanic "FlattenMonad.mk'eq: " (ppr ty) + +-- generate an application of `==' where the arguments may only be literals +-- that may occur in a Core case expression (i.e., `Char', `Int', `Float', and +-- `Double') (EXPORTED) +-- +mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'neq ty a1 a2 = mkFunApp neqName [a1, a2] + where + name = tyConName . tyConAppTyCon $ ty + -- + neqName | name == charPrimTyConName = neqCharName + | name == intPrimTyConName = neqIntName + | name == floatPrimTyConName = neqFloatName + | name == doublePrimTyConName = neqDoubleName + | otherwise = + pprPanic "FlattenMonad.mk'neq: " (ppr ty) + +-- generate an application of `lengthP' (EXPORTED) +-- +mk'lengthP :: Type -> CoreExpr -> Flatten CoreExpr +mk'lengthP ty a = mkFunApp lengthPName [Type ty, a] + +-- generate an application of `replicateP' (EXPORTED) +-- +mk'replicateP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'replicateP ty a1 a2 = mkFunApp replicatePName [Type ty, a1, a2] + +-- generate an application of `replicateP' (EXPORTED) +-- +mk'mapP :: Type -> Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'mapP ty1 ty2 a1 a2 = mkFunApp mapPName [Type ty1, Type ty2, a1, a2] + +-- generate an application of `bpermuteP' (EXPORTED) +-- +mk'bpermuteP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'bpermuteP ty a1 a2 = mkFunApp bpermutePName [Type ty, a1, a2] + +-- generate an application of `bpermuteDftP' (EXPORTED) +-- +mk'bpermuteDftP :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'bpermuteDftP ty a1 a2 a3 = mkFunApp bpermuteDftPName [Type ty, a1, a2, a3] + +-- generate an application of `indexOfP' (EXPORTED) +-- +mk'indexOfP :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr +mk'indexOfP ty a1 a2 = mkFunApp indexOfPName [Type ty, a1, a2] + + +-- auxilliary functions +-- -------------------- + +-- obtain the context variable, aborting if it is not available (as this +-- signals an internal error in the usage of the `Flatten' monad) +-- +ctxtVarErr :: FlattenState -> Var +ctxtVarErr s = case ctxtVar s of + Nothing -> panic "FlattenMonad.ctxtVarErr: No context \ + \variable available!" + Just v -> v + +-- given the name of a known function and a set of arguments (needs to include +-- all needed type arguments), build a Core expression that applies the named +-- function to those arguments +-- +mkFunApp :: Name -> [CoreExpr] -> Flatten CoreExpr +mkFunApp name args = + do + fun <- lookupName name + return $ mkApps (Var fun) args + +-- get the `Id' of a known `Name' +-- +-- * this can be the `Name' of any function that's visible on the toplevel of +-- the current compilation unit +-- +lookupName :: Name -> Flatten Id +lookupName name = Flatten $ \s -> + (env s name, s) diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs new file mode 100644 index 0000000..4733bc4 --- /dev/null +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -0,0 +1,812 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Vectorisation and lifting +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module implements the vectorisation and function lifting +-- transformations of the flattening transformation. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 with C preprocessor +-- +-- Types: +-- the transformation on types has five purposes: +-- +-- 1) for each type definition, derive the lifted version of this type +-- liftTypeef +-- 2) change the type annotations of functions & variables acc. to rep. +-- flattenType +-- 3) derive the type of a lifted function +-- liftType +-- 4) sumtypes: +-- this is the most fuzzy and complicated part. For each lifted +-- sumtype we need to generate function to access and combine the +-- component arrays +-- +-- NOTE: the type information of variables and data constructors is *not* +-- changed to reflect it's representation. This has to be solved +-- somehow (???, FIXME) using type indexed types +-- +-- Vectorisation: +-- is very naive at the moment. One of the most striking inefficiencies is +-- application vect (app e1 e2) -> app (fst (vect e1) (vect e2)) if e1 is a +-- lambda abstraction. The vectorisation produces a pair consisting of the +-- original and the lifted function, but the lifted version is discarded. +-- I'm also not sure how much of this would be thrown out by the simplifier +-- eventually +-- +-- *) vectorise +-- +-- Conventions: +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * look closer into the definition of type definition (TypeThing or so) +-- + +module Flattening ( + flatten, flattenExpr, +) where + +-- standard +import Monad (liftM, foldM) + +-- GHC +import CmdLineOpts (opt_Flatten) +import Panic (panic) +import ErrUtils (dumpIfSet_dyn) +import UniqSupply (UniqSupply, mkSplitUniqSupply) +import CmdLineOpts (DynFlag(..), DynFlags) +import Literal (Literal, literalType) +import Var (Var(..),TyVar) +import DataCon (DataCon, dataConTag) +import TypeRep (Type(..)) +import Type (isTypeKind) +import HscTypes (HomeSymbolTable, PersistentCompilerState, ModDetails(..)) +import CoreFVs (exprFreeVars) +import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), + CoreBndr, CoreExpr, CoreBind, CoreAlt, mkLams, mkLets, + mkApps, mkIntLitInt) +import PprCore (pprCoreExpr) +import CoreLint (showPass, endPass) + +import CoreUtils (exprType, applyTypeToArg, mkPiType) +import VarEnv (IdEnv, mkVarEnv, zipVarEnv, extendVarEnv) +import TysWiredIn (mkTupleTy) +import BasicTypes (Boxity(..)) +import Outputable (showSDoc, Outputable(..)) + + +-- friends +import NDPCoreUtils (tupleTyArgs, funTyArgs, parrElemTy, isDefault, + isLit, mkPArrTy, mkTuple, isSimpleExpr, boolTy, substIdEnv) +import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext, + liftVar, liftConst, intersectWithContext, mk'fst, + mk'lengthP, mk'replicateP, mk'mapP, mk'bpermuteDftP, + mk'indexOfP,mk'eq,mk'neq) + +-- FIXME: fro debugging - remove this +import IOExts (trace) + + +#include "HsVersions.h" +{-# INLINE slit #-} +slit x = FastString.mkFastCharString# x +-- FIXME: SLIT() doesn't work for some strange reason + + +-- toplevel transformation +-- ----------------------- + +-- entry point to the flattening transformation for the compiler driver when +-- compiling a complete module (EXPORTED) +-- +flatten :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> ModDetails -- the module to be flattened + -> IO ModDetails +flatten dflags pcs hst modDetails@(ModDetails {md_binds = binds}) + | not opt_Flatten = return modDetails -- skip without -fflatten + | otherwise = + do + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening + -- + -- announce vectorisation + -- + showPass dflags "Flattening [first phase: vectorisation]" + -- + -- vectorise all toplevel bindings + -- + let binds' = runFlatten pcs hst us $ vectoriseTopLevelBinds binds + -- + -- and dump the result if requested + -- + endPass dflags "Flattening [first phase: vectorisation]" + Opt_D_dump_vect binds' + return $ modDetails {md_binds = binds'} + +-- entry point to the flattening transformation for the compiler driver when +-- compiling a single expression in interactive mode (EXPORTED) +-- +flattenExpr :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> CoreExpr -- the expression to be flattened + -> IO CoreExpr +flattenExpr dflags pcs hst expr + | not opt_Flatten = return expr -- skip without -fflatten + | otherwise = + do + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening + -- + -- announce vectorisation + -- + showPass dflags "Flattening [first phase: vectorisation]" + -- + -- vectorise the expression + -- + let expr' = fst . runFlatten pcs hst us $ vectorise expr + -- + -- and dump the result if requested + -- + dumpIfSet_dyn dflags Opt_D_dump_vect "Vectorised expression" + (pprCoreExpr expr') + return expr' + + +-- vectorisation of bindings and expressions +-- ----------------------------------------- + + +vectoriseTopLevelBinds:: [CoreBind] -> Flatten [CoreBind] +vectoriseTopLevelBinds binds = + do + vbinds <- mapM vectoriseBind binds + return (adjustTypeBinds vbinds) + +adjustTypeBinds:: [CoreBind] -> [CoreBind] +adjustTypeBinds vbinds = + let + ids = concat (map extIds vbinds) + idEnv = zipVarEnv ids ids + in map (substIdEnvBind idEnv) vbinds + where + -- FIXME replace by 'bindersOf' + extIds (NonRec b expr) = [b] + extIds (Rec bnds) = map fst bnds + substIdEnvBind idEnv (NonRec b expr) = NonRec b (substIdEnv idEnv expr) + substIdEnvBind idEnv (Rec bnds) + = Rec (map (\ (b,e) -> (b, (substIdEnv idEnv e))) bnds) + +-- vectorise a single core binder +-- +vectoriseBind :: CoreBind -> Flatten CoreBind +vectoriseBind (NonRec b expr) = + liftM (NonRec b) $ liftM fst $ vectorise expr +vectoriseBind (Rec bindings) = + liftM Rec $ mapM vectoriseOne bindings + where + vectoriseOne (b, expr) = + do + (vexpr, ty) <- vectorise expr + return (b{varType = ty}, vexpr) + + +-- Searches for function definitions and creates a lifted version for +-- each function. +-- We have only two interesting cases: +-- 1) function application (ex1) (ex2) +-- vectorise both subexpressions. The function will end up becoming a +-- pair (orig. fun, lifted fun), choose first component (in many cases, +-- this is pretty inefficient, since the lifted version is generated +-- although it is clear that it won't be used +-- +-- 2) lambda abstraction +-- any function has to exist in two forms: it's original form and it's +-- lifted form. Therefore, every lambda abstraction is transformed into +-- a pair of functions: the original function and its lifted variant +-- +-- +-- FIXME: currently, I use 'exprType' all over the place - this is terribly +-- inefficient. It should be suffiecient to change 'vectorise' and 'lift' to +-- return the type of the result expression as well. +-- +vectorise:: CoreExpr -> Flatten (CoreExpr, Type) +vectorise (Var id) = + do + let varTy = varType id + let vecTy = vectoriseTy varTy + return ((Var id{varType = vecTy}), vecTy) + +vectorise (Lit lit) = + return ((Lit lit), literalType lit) + + +vectorise e@(App expr t@(Type _)) = + do + (vexpr, vexprTy) <- vectorise expr + return ((App vexpr t), applyTypeToArg vexprTy t) + +vectorise (App (Lam b expr) arg) = + do + (varg, argTy) <- vectorise arg + (vexpr, vexprTy) <- vectorise expr + let vb = b{varType = argTy} + return ((App (Lam vb vexpr) varg), + applyTypeToArg (mkPiType vb vexprTy) varg) + +-- if vexpr expects a type as first argument +-- application stays just as it is +-- +vectorise (App expr arg) = + do + (vexpr, vexprTy) <- vectorise expr + (varg, vargTy) <- vectorise arg + + if (isPolyType vexprTy) + then do + let resTy = applyTypeToArg vexprTy varg + return (App vexpr varg, resTy) + else do + let [t1, t2] = tupleTyArgs vexprTy + vexpr' <- mk'fst t1 t2 vexpr + let resTy = applyTypeToArg t1 varg + return ((App vexpr' varg), resTy) -- apply the first component of + -- the vectorized function + where + isPolyType t = + (case t of + (ForAllTy _ _) -> True + (NoteTy _ nt) -> isPolyType nt + _ -> False) + + +vectorise e@(Lam b expr) + | isTypeKind (varType b) = + do + (vexpr, vexprTy) <- vectorise expr -- don't vectorise 'b'! + return ((Lam b vexpr), mkPiType b vexprTy) + | otherwise = + do + (vexpr, vexprTy) <- vectorise expr + let vb = b{varType = vectoriseTy (varType b)} + let ve = Lam vb vexpr + (lexpr, lexprTy) <- lift e + let veTy = mkPiType vb vexprTy + return $ (mkTuple [veTy, lexprTy] [ve, lexpr], + mkTupleTy Boxed 2 [veTy, lexprTy]) + +vectorise (Let bind body) = + do + vbind <- vectoriseBind bind + (vbody, vbodyTy) <- vectorise body + return ((Let vbind vbody), vbodyTy) + +vectorise (Case expr b alts) = + do + (vexpr, vexprTy) <- vectorise expr + valts <- mapM vectorise' alts + return (Case vexpr b{varType = vexprTy} (map fst valts), snd (head valts)) + where vectorise' (con, bs, expr) = + do + (vexpr, vexprTy) <- vectorise expr + return ((con, bs, vexpr), vexprTy) -- FIXME: change type of con + -- and bs + + + +vectorise (Note note expr) = + do + (vexpr, vexprTy) <- vectorise expr -- FIXME: is this ok or does it + return ((Note note vexpr), vexprTy) -- change the validity of note? + +vectorise e@(Type t) = + return (e, t) -- FIXME: panic instead of 't'??? + + +{- +myShowTy (TyVarTy _) = "TyVar " +myShowTy (AppTy t1 t2) = + "AppTy (" ++ (myShowTy t1) ++ ", " ++ (myShowTy t2) ++ ")" +myShowTy (TyConApp _ t) = + "TyConApp TC (" ++ (myShowTy t) ++ ")" +-} + +vectoriseTy :: Type -> Type +vectoriseTy t@(TyVarTy v) = t +vectoriseTy t@(AppTy t1 t2) = + AppTy (vectoriseTy t1) (vectoriseTy t2) +vectoriseTy t@(TyConApp tc ts) = + TyConApp tc (map vectoriseTy ts) +vectoriseTy t@(FunTy t1 t2) = + mkTupleTy Boxed 2 [(FunTy (vectoriseTy t1) (vectoriseTy t2)), + (liftTy t)] +vectoriseTy t@(ForAllTy v ty) = + ForAllTy v (vectoriseTy ty) +vectoriseTy t@(NoteTy note ty) = -- FIXME: is the note still valid after + NoteTy note (vectoriseTy ty) -- this or should we just throw it away +vectoriseTy t = t + + +-- liftTy: wrap the type in an array but be careful with function types +-- on the *top level* (is this sufficient???) + +liftTy:: Type -> Type +liftTy (FunTy t1 t2) = FunTy (liftTy t1) (liftTy t2) +liftTy (ForAllTy tv t) = ForAllTy tv (liftTy t) +liftTy (NoteTy n t) = NoteTy n $ liftTy t +liftTy t = mkPArrTy t + + +-- lifting: +-- ---------- +-- * liftType +-- * lift + + +-- liftBinderType: Converts a type 'a' stored in the binder to the +-- representation of '[:a:]' will therefore call liftType +-- +-- lift type, don't change name (incl unique) nor IdInfo. IdInfo looks ok, +-- but I'm not entirely sure about some fields (e.g., strictness info) +liftBinderType:: CoreBndr -> Flatten CoreBndr +liftBinderType bndr = return $ bndr {varType = liftTy (varType bndr)} + +-- lift: lifts an expression (a -> [:a:]) +-- If the expression is a simple expression, it is treated like a constant +-- expression. +-- If the body of a lambda expression is a simple expression, it is +-- transformed into a mapP +lift:: CoreExpr -> Flatten (CoreExpr, Type) +lift cExpr@(Var id) = + do + lVar@(Var lId) <- liftVar id + return (lVar, varType lId) + +lift cExpr@(Lit lit) = + do + lLit <- liftConst cExpr + return (lLit, exprType lLit) + + +lift (Lam b expr) + | isSimpleExpr expr = liftSimpleFun b expr + | isTypeKind (varType b) = + do + (lexpr, lexprTy) <- lift expr -- don't lift b! + return (Lam b lexpr, mkPiType b lexprTy) + | otherwise = + do + lb <- liftBinderType b + (lexpr, lexprTy) <- extendContext [lb] (lift expr) + return ((Lam lb lexpr) , mkPiType lb lexprTy) + +lift (App expr1 expr2) = + do + (lexpr1, lexpr1Ty) <- lift expr1 + (lexpr2, _) <- lift expr2 + return ((App lexpr1 lexpr2), applyTypeToArg lexpr1Ty lexpr2) + + +lift (Let (NonRec b expr1) expr2) + |isSimpleExpr expr2 = + do + (lexpr1, _) <- lift expr1 + (lexpr2, lexpr2Ty) <- liftSimpleFun b expr2 + let (t1, t2) = funTyArgs lexpr2Ty + liftM (\x -> (x, liftTy t2)) $ mk'mapP t1 t2 lexpr2 lexpr1 + + | otherwise = + do + (lexpr1, _) <- lift expr1 + lb <- liftBinderType b + (lexpr2, lexpr2Ty) <- extendContext [lb] (lift expr1) + return ((Let (NonRec lb lexpr1) lexpr2), lexpr2Ty) + +lift (Let (Rec binds) expr2) = + do + let (bndVars, exprs) = unzip binds + lBndVars <- mapM liftBinderType bndVars + lexprs <- extendContext bndVars (mapM lift exprs) + (lexpr2, lexpr2Ty) <- extendContext bndVars (lift expr2) + return ((Let (Rec (zip lBndVars (map fst lexprs))) lexpr2), lexpr2Ty) + +-- FIXME: +-- Assumption: alternatives can either be literals or data construtors. +-- Due to type restrictions, I don't think it is possible +-- that they are mixed. +-- The handling of literals and data constructors is completely +-- different +-- +-- +-- let b = expr in alts +-- +-- I think I read somewhere that the default case (if present) is stored +-- in the head of the list. Assume for now this is true, have to check +-- +-- (1) literals +-- (2) data constructors +-- +-- FIXME: optimisation: first, filter out all simple expression and +-- loop (mapP & filter) over all the corresponding values in a single +-- traversal: + +-- (1) splitAlts:: [Alt CoreBndr] -> ([Alt CoreBndr],[Alt CoreBndr]) +-- simple alts reg alts +-- (2) if simpleAlts = [] then (just as before) +-- if regAlts = [] then (the whole thing is just a loop) +-- otherwise (a) compute index vector for simpleAlts (for def permute +-- later on +-- (b) +lift cExpr@(Case expr b alts) = + do + (lExpr, _) <- lift expr + lb <- liftBinderType b -- lift alt-expression + lalts <- if isLit alts + then extendContext [lb] (liftCaseLit b alts) + else extendContext [lb] (liftCaseDataCon b alts) + letWrapper lExpr b lalts + +lift (Note (Coerce t1 t2) expr) = + do + (lexpr, t) <- lift expr + let lt1 = liftTy t1 + return ((Note (Coerce lt1 (liftTy t2)) lexpr), lt1) + +lift (Note note expr) = + do + (lexpr, t) <- lift expr + return ((Note note lexpr), t) + +lift e@(Type t) = return (e, t) + + +-- auxilliary functions for lifting of case statements +-- + +liftCaseDataCon:: CoreBndr -> [Alt CoreBndr] -> + Flatten (([CoreBind], [CoreBind], [CoreBind])) +liftCaseDataCon b [] = + return ([], [], []) +liftCaseDataCon b alls@(alt:alts) + | isDefault alt = + do + (i, e, defAltBndrs) <- liftCaseDataConDefault b alt alts + (is, es, altBndrs) <- liftCaseDataCon' b alts + return (i:is, e:es, defAltBndrs ++ altBndrs) + | otherwise = + liftCaseDataCon' b alls + +liftCaseDataCon':: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseDataCon' _ [] = + do + return ([], [], []) + + +liftCaseDataCon' b ((DataAlt dcon, bnds, expr): alts) = + do + (permBnd, exprBnd, packBnd) <- liftSingleDataCon b dcon bnds expr + (permBnds, exprBnds, packBnds) <- liftCaseDataCon' b alts + return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds) + + +-- FIXME: is is really necessary to return the binding to the permutation +-- array in the data constructor case, as the representation already +-- contains the extended flag vector +liftSingleDataCon:: CoreBndr -> DataCon -> [CoreBndr] -> CoreExpr -> + Flatten (CoreBind, CoreBind, [CoreBind]) +liftSingleDataCon b dcon bnds expr = + do + let dconId = dataConTag dcon + indexExpr <- mkIndexOfExprDCon (varType b) b dconId + (b', bbind) <- mkBind (slit "is"#) indexExpr + lbnds <- mapM liftBinderType bnds + ((lExpr, _), bnds') <- packContext b' (extendContext lbnds (lift expr)) + (_, vbind) <- mkBind (slit "r"#) lExpr + return (bbind, vbind, bnds') + +-- FIXME: clean this up. the datacon and the literal case are so +-- similar that it would be easy to use the same function here +-- instead of duplicating all the code. +-- +liftCaseDataConDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] + -> Flatten (CoreBind, CoreBind, [CoreBind]) +liftCaseDataConDefault b (_, _, def) alts = + do + let dconIds = map (\(DataAlt d, _, _) -> dataConTag d) alts + indexExpr <- mkIndexOfExprDConDft (varType b) b dconIds + (b', bbind) <- mkBind (slit "is"#) indexExpr + ((lDef, _), bnds) <- packContext b' (lift def) + (_, vbind) <- mkBind (slit "r"#) lDef + return (bbind, vbind, bnds) + +-- liftCaseLit: checks if we have a default case and handles it +-- if necessary +liftCaseLit:: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseLit b [] = + return ([], [], []) --FIXME: a case with no cases at all??? +liftCaseLit b alls@(alt:alts) + | isDefault alt = + do + (i, e, defAltBndrs) <- liftCaseLitDefault b alt alts + (is, es, altBndrs) <- liftCaseLit' b alts + return (i:is, e:es, defAltBndrs ++ altBndrs) + | otherwise = + do + liftCaseLit' b alls + +-- liftCaseLitDefault: looks at all the other alternatives which +-- contain a literal and filters all those elements from the +-- array which do not match any of the literals in the other +-- alternatives. +liftCaseLitDefault:: CoreBndr -> (Alt CoreBndr) -> [Alt CoreBndr] + -> Flatten (CoreBind, CoreBind, [CoreBind]) +liftCaseLitDefault b (_, _, def) alts = + do + let lits = map (\(LitAlt l, _, _) -> l) alts + indexExpr <- mkIndexOfExprDft (varType b) b lits + (b', bbind) <- mkBind (slit "is"#) indexExpr + ((lDef, _), bnds) <- packContext b' (lift def) + (_, vbind) <- mkBind (slit "r"#) lDef + return (bbind, vbind, bnds) + +-- FIXME: +-- Assumption: in case of Lit, the list of binders of the alt is empty. +-- +-- returns +-- a list of all vars bound to the expr in the body of the alternative +-- a list of (var, expr) pairs, where var has to be bound to expr +-- by letWrapper +liftCaseLit':: CoreBndr -> [Alt CoreBndr] -> + Flatten ([CoreBind], [CoreBind], [CoreBind]) +liftCaseLit' _ [] = + do + return ([], [], []) +liftCaseLit' b ((LitAlt lit, [], expr):alts) = + do + (permBnd, exprBnd, packBnd) <- liftSingleCaseLit b lit expr + (permBnds, exprBnds, packBnds) <- liftCaseLit' b alts + return (permBnd:permBnds, exprBnd:exprBnds, packBnd ++ packBnds) + +-- lift a single alternative of the form: case b of lit -> expr. +-- +-- It returns the bindings: +-- (a) let b' = indexOfP (mapP (\x -> x == lit) b) +-- +-- (b) lift expr in the packed context. Returns lexpr and the +-- list of binds (bnds) that describe the packed arrays +-- +-- (c) create new var v' to bind lexpr to +-- +-- (d) return (b' = indexOf...., v' = lexpr, bnds) +liftSingleCaseLit:: CoreBndr -> Literal -> CoreExpr -> + Flatten (CoreBind, CoreBind, [CoreBind]) +liftSingleCaseLit b lit expr = + do + indexExpr <- mkIndexOfExpr (varType b) b lit -- (a) + (b', bbind) <- mkBind (slit "is"#) indexExpr + ((lExpr, t), bnds) <- packContext b' (lift expr) -- (b) + (_, vbind) <- mkBind (slit "r"#) lExpr + return (bbind, vbind, bnds) + +-- letWrapper lExpr b ([indexbnd_i], [exprbnd_i], [pckbnd_ij]) +-- +-- let b = lExpr in +-- let index_bnd_1 in +-- let packbnd_11 in +-- ... packbnd_1m in +-- let exprbnd_1 in .... +-- ... +-- let nvar = replicate dummy (length ) +-- nvar1 = bpermuteDftP index_bnd_1 ... +-- +-- in bpermuteDftP index_bnd_n nvar_(n-1) +-- +letWrapper:: CoreExpr -> CoreBndr ->([CoreBind], [CoreBind], [CoreBind]) -> + Flatten (CoreExpr, Type) +letWrapper lExpr b (indBnds, exprBnds, pckBnds) = + do + (defBpBnds, ty) <- dftbpBinders indBnds exprBnds + let resExpr = getExprOfBind (head defBpBnds) + return ((mkLets (indBnds ++ pckBnds ++ exprBnds ++ defBpBnds) resExpr), ty) + +-- dftbpBinders: return the list of binders necessary to construct the overall +-- result from the subresults computed in the different branches of the case +-- statement. The binding which contains the final result is in the *head* +-- of the result list. +-- +-- dftbpBinders [ind_i = ...] [expr_i = ...] = [dn = ..., d_n-1 = .., d1 = ...] +-- +-- let def = replicate (length of context) undefined +-- d1 = bpermuteDftP dft e1 i1 +-- ..... +-- +dftbpBinders:: [CoreBind] -> [CoreBind] -> Flatten ([CoreBind], Type) +dftbpBinders indexBnds exprBnds = + do + let expr = getExprOfBind (head exprBnds) + defVecExpr <- createDftArrayBind expr + ((b, bnds), t) <- dftbpBinders' indexBnds exprBnds defVecExpr + return ((b:bnds),t) + where + dftbpBinders' :: [CoreBind] + -> [CoreBind] + -> CoreBind + -> Flatten ((CoreBind, [CoreBind]), Type) + dftbpBinders' [] [] cBnd = + return ((cBnd, []), panic "dftbpBinders: undefined type") + dftbpBinders' (i:is) (e:es) cBind = + do + let iVar = getVarOfBind i + let eVar = getVarOfBind e + let cVar = getVarOfBind cBind + let ty = varType eVar + newBnd <- mkDftBackpermute ty iVar eVar cVar + ((fBnd, restBnds), _) <- dftbpBinders' is es newBnd + return ((fBnd, (newBnd:restBnds)), liftTy ty) + + dftbpBinders' _ _ _ = + panic "Flattening.dftbpBinders: index and expression binder lists \ + \have different length!" + +getExprOfBind:: CoreBind -> CoreExpr +getExprOfBind (NonRec _ expr) = expr + +getVarOfBind:: CoreBind -> Var +getVarOfBind (NonRec b _) = b + + + +-- Optimised Transformation +-- ========================= +-- + +-- liftSimpleFun +-- if variables x_1 to x_i occur in the context *and* free in expr +-- then +-- (liftSimpleExpression expr) => mapP (\ (x1,..xn) -> expr) (x1,..xn) +-- +liftSimpleFun:: CoreBndr -> CoreExpr -> Flatten (CoreExpr, Type) +liftSimpleFun b expr = + do + bndVars <- collectBoundVars expr + let bndVars' = b:bndVars + bndVarsTuple = mkTuple (map varType bndVars') (map Var bndVars') + lamExpr = mkLams (b:bndVars) expr -- FIXME: should be tuple + -- here + let (t1, t2) = funTyArgs . exprType $ lamExpr + mapExpr <- mk'mapP t1 t2 lamExpr bndVarsTuple + let lexpr = mkApps mapExpr [bndVarsTuple] + return (lexpr, undefined) -- FIXME!!!!! + + +collectBoundVars:: CoreExpr -> Flatten [CoreBndr] +collectBoundVars expr = + intersectWithContext (exprFreeVars expr) + + +-- auxilliary routines +-- ------------------- + +-- mkIndexOfExpr b lit -> +-- indexOf (mapP (\x -> x == lit) b) b +-- +mkIndexOfExpr:: Type -> CoreBndr -> Literal -> Flatten CoreExpr +mkIndexOfExpr varType b lit = + do + eqExpr <- mk'eq varType (Var b) (Lit lit) + let lambdaExpr = (Lam b eqExpr) + mk'indexOfP varType lambdaExpr (Var b) + +-- there is FlattenMonad.mk'indexOfP as well as +-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here + +-- for case-distinction over data constructors: +-- let b = expr in +-- case b of +-- dcon args -> .... +-- dconId = dataConTag dcon +-- the call "mkIndexOfExprDCon b dconId" computes the core expression for +-- indexOfP (\x -> x == dconId) b) +-- +mkIndexOfExprDCon::Type -> CoreBndr -> Int -> Flatten CoreExpr +mkIndexOfExprDCon varType b dId = + do + let intExpr = mkIntLitInt dId + eqExpr <- mk'eq varType (Var b) intExpr + let lambdaExpr = (Lam b intExpr) + mk'indexOfP varType lambdaExpr (Var b) + + + +-- there is FlattenMonad.mk'indexOfP as well as +-- CoreSyn.mkApps and CoreSyn.mkLam, all of which should help here + +-- mk'IndexOfExprDConDft b dconIds : Generates the index expression for the +-- default case. "dconIds" is a list of all the data constructor idents which +-- are covered by the other cases. +-- indexOfP (\x -> x != dconId_1 && ....) b) +-- +mkIndexOfExprDConDft:: Type -> CoreBndr -> [Int] -> Flatten CoreExpr +mkIndexOfExprDConDft varType b dId = + do + let intExprs = map mkIntLitInt dId + bExpr <- foldM (mk'neq varType) (head intExprs) (tail intExprs) + let lambdaExpr = (Lam b bExpr) + mk'indexOfP varType (Var b) bExpr + + +-- mkIndexOfExprDef b [lit1, lit2,...] -> +-- indexOf (\x -> not (x == lit1 || x == lit2 ....) b +mkIndexOfExprDft:: Type -> CoreBndr -> [Literal] -> Flatten CoreExpr +mkIndexOfExprDft varType b lits = + do + let litExprs = map (\l-> Lit l) lits + bExpr <- foldM (mk'neq varType) (head litExprs) (tail litExprs) + let lambdaExpr = (Lam b bExpr) + mk'indexOfP varType bExpr (Var b) + + +-- create a back-permute binder +-- +-- * `mkDftBackpermute ty indexArrayVar srcArrayVar dftArrayVar' creates a +-- Core binding of the form +-- +-- x = bpermuteDftP indexArrayVar srcArrayVar dftArrayVar +-- +-- where `x' is a new local variable +-- +mkDftBackpermute :: Type -> Var -> Var -> Var -> Flatten CoreBind +mkDftBackpermute ty idx src dft = + do + rhs <- mk'bpermuteDftP ty (Var idx) (Var src) (Var dft) + liftM snd $ mkBind (slit "dbp"#) rhs + +-- create a dummy array with elements of the given type, which can be used as +-- default array for the combination of the subresults of the lifted case +-- expression +-- +createDftArrayBind :: CoreExpr -> Flatten CoreBind +createDftArrayBind e = + panic "Flattening.createDftArrayBind: not implemented yet" +{- + do + let ty = parrElemTy . exprType $ expr + len <- mk'lengthP e + rhs <- mk'replicateP ty len err?? + lift snd $ mkBind (slit "dft"#) rhs +FIXME: nicht so einfach; man kann kein "error"-Wert nehmen, denn der w"urde + beim bpermuteDftP sofort evaluiert, aber es ist auch schwer m"oglich einen + generischen Wert f"ur jeden beliebigen Typ zu erfinden. +-} + + + + +-- show functions (the pretty print functions sometimes don't +-- show it the way I want.... + +-- shows just the structure +showCoreExpr (Var _ ) = "Var " +showCoreExpr (Lit _) = "Lit " +showCoreExpr (App e1 e2) = + "(App \n " ++ (showCoreExpr e1) ++ "\n " ++ (showCoreExpr e2) ++ ") " +showCoreExpr (Lam b e) = + "Lam b " ++ (showCoreExpr e) +showCoreExpr (Let bnds expr) = + "Let \n" ++ (showBinds bnds) ++ "in " ++ (showCoreExpr expr) + where showBinds (NonRec b e) = showBind (b,e) + showBinds (Rec bnds) = concat (map showBind bnds) + showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n" +showCoreExpr (Case ex b alts) = + "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts) + where showAlts _ = "" +showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex) +showCoreExpr (Type t) = "Type" \ No newline at end of file diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs new file mode 100644 index 0000000..1d221ba --- /dev/null +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -0,0 +1,175 @@ +-- $Id$ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Auxiliary routines for NDP-related Core transformations. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module exports all functions to access and alter the `Type' data +-- structure from modules `Type' and `CoreExpr' from `CoreSyn'. As it is part +-- of the NDP flattening component, the functions provide access to all the +-- fields that are important for the flattening and lifting transformation. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 +-- +--- TODO ---------------------------------------------------------------------- +-- + +module NDPCoreUtils ( + + -- type inspection functions + -- + tupleTyArgs, -- :: Type -> [Type] + funTyArgs, -- :: Type -> (Type, Type) + parrElemTy, -- :: Type -> Type + + -- Core generation functions + -- + mkTuple, -- :: [Type] -> [CoreExpr] -> CoreExpr + mkInt, -- :: CoreExpr -> CoreExpr + + -- query functions + -- + isDefault, -- :: CoreAlt -> Bool + isLit, -- :: [CoreAlt] -> Bool + isSimpleExpr, -- :: CoreExpr -> Bool + + -- re-exported functions + -- + mkPArrTy, -- :: Type -> Type + boolTy, -- :: Type + + -- substitution + -- + substIdEnv +) where + +-- GHC +import Panic (panic) +import Outputable (Outputable(ppr), pprPanic) +import BasicTypes (Boxity(..)) +import Var (Var) +import Type (Type, splitTyConApp_maybe, splitFunTy) +import TyCon (TyCon(..), isTupleTyCon) +import PrelNames (parrTyConName) +import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy, + boolTy) +import CoreSyn (CoreBndr, CoreExpr, CoreBind, CoreAlt, Expr(..), AltCon(..), + Bind(..), mkConApp) +import Var (Id) +import VarEnv (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv) + +-- friends: don't import any to avoid cyclic imports +-- + + +-- type inspection functions +-- ------------------------- + +-- determines the argument types of a tuple type (EXPORTED) +-- +tupleTyArgs :: Type -> [Type] +tupleTyArgs ty = + case splitTyConApp_maybe ty of + Just (tyCon, argTys) | isTupleTyCon tyCon -> argTys + _ -> + pprPanic "NDPCoreUtils.tupleTyArgs: wrong type: " (ppr ty) + +-- determines the argument and result type of a function type (EXPORTED) +-- +funTyArgs :: Type -> (Type, Type) +funTyArgs = splitFunTy + +-- for a type of the form `[:t:]', yield `t' (EXPORTED) +-- +-- * if the type has any other form, a fatal error occurs +-- +parrElemTy :: Type -> Type +parrElemTy ty = + case splitTyConApp_maybe ty of + Just (tyCon, [argTy]) | tyConName tyCon == parrTyConName -> argTy + _ -> + pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty) + + +-- Core generation functions +-- ------------------------- + +-- make a tuple construction expression from a list of argument types and +-- argument values (EXPORTED) +-- +-- * the two lists need to be of the same length +-- +mkTuple :: [Type] -> [CoreExpr] -> CoreExpr +mkTuple [] [] = Var unitDataConId +mkTuple [_] [e] = e +mkTuple ts es | length ts == length es = + mkConApp (tupleCon Boxed (length es)) (map Type ts ++ es) +mkTuple _ _ = + panic "NDPCoreUtils.mkTuple: mismatch between number of types and exprs!" + +-- make a boxed integer from an unboxed one (EXPORTED) +-- +mkInt :: CoreExpr -> CoreExpr +mkInt e = mkConApp intDataCon [e] + + +-- query functions +-- --------------- + +-- checks whether a given case alternative is a default alternative (EXPORTED) +-- +isDefault :: CoreAlt -> Bool +isDefault (DEFAULT, _, _) = True +isDefault _ = False + +-- check whether a list of case alternatives in belongs to a case over a +-- literal type (EXPORTED) +-- +isLit :: [CoreAlt] -> Bool +isLit ((DEFAULT, _, _ ):alts) = isLit alts +isLit ((LitAlt _, _, _):_ ) = True +isLit _ = False + +-- FIXME: this function should get a more expressive name and maybe also a +-- more detailed return type (depends on how the analysis goes) +isSimpleExpr:: CoreExpr -> Bool +isSimpleExpr _ = + -- FIXME + False + + +-- Substitution +-- ------------- + +substIdEnv:: IdEnv Id -> CoreExpr -> CoreExpr +substIdEnv env e@(Lit _) = e +substIdEnv env e@(Var id) = + case (lookupVarEnv env id) of + Just v -> (Var v) + _ -> e +substIdEnv env (App e arg) = + App (substIdEnv env e) (substIdEnv env arg) +substIdEnv env (Lam b expr) = + Lam b (substIdEnv (delVarEnv env b) expr) +substIdEnv env (Let (NonRec b expr1) expr2) = + Let (NonRec b (substIdEnv env expr1)) + (substIdEnv (delVarEnv env b) expr2) +substIdEnv env (Let (Rec bnds) expr) = + let + newEnv = delVarEnvList env (map fst bnds) + newExpr = substIdEnv newEnv expr + substBnd (b,e) = (b, substIdEnv newEnv e) + in Let (Rec (map substBnd bnds)) newExpr +substIdEnv env (Case expr b alts) = + Case (substIdEnv newEnv expr) b (map substAlt alts) + where + newEnv = delVarEnv env b + substAlt (c, bnds, expr) = + (c, bnds, substIdEnv (delVarEnvList env bnds) expr) +substIdEnv env (Note n expr) = + Note n (substIdEnv env expr) +substIdEnv env e@(Type t) = e \ No newline at end of file diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs new file mode 100644 index 0000000..0c25805 --- /dev/null +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -0,0 +1,202 @@ +-- $Id$ +-- +-- Copyright (c) 2002 Manuel M T Chakravarty & Gabriele Keller +-- +-- Analysis phase for an optimised flattening transformation +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module implements an analysis phase that identifies Core expressions +-- that need not be transformed during flattening. The expressions when +-- executed in a parallel context are implemented as an iteration over the +-- original scalar computation, instead of vectorising the computation. This +-- usually improves efficiency by increasing locality and also reduces code +-- size. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 with C preprocessor +-- +-- Analyse the expression and annotate each simple subexpression accordingly. +-- +-- The result of the analysis is stored in a new field in IdInfo (has yet to +-- be extended) +-- +-- A simple expression is any expression which is not a function, not of +-- recursive type and does not contain a value of PArray type. Polymorphic +-- variables are simple expressions even though they might be instantiated to +-- a parray value or function. +-- +--- TODO ---------------------------------------------------------------------- +-- + +module PArrAnal ( + markScalarExprs -- :: [CoreBind] -> [CoreBind] +) where + +import Panic (panic) +import Outputable (pprPanic, ppr) +import CoreSyn (CoreBind) + +import TypeRep (Type(..)) +import Var (Var(..),Id) +import Literal (Literal) +import CoreSyn (Expr(..),CoreExpr,Bind(..)) +-- + +data ArrayUsage = Prim | NonPrim | Array + | PolyExpr (Id -> Maybe (ArrayUsage -> ArrayUsage)) + | PolyFun (ArrayUsage -> ArrayUsage) + + +arrUsage:: CoreExpr -> ArrayUsage +arrUsage (Var id) = varArrayUsage id +arrUsage (Lit lit) = litArrayUsage lit +arrUsage (App expr1 expr2) = + let + arr1 = arrUsage expr1 + arr2 = arrUsage expr2 + in + case (arr1, arr2) of + (_, Array) -> Array + (PolyFun f, _) -> f arr2 + (_, _) -> arr1 + +arrUsage (Lam b expr) = + bindType (b, expr) + +arrUsage (Let (NonRec b expr1) expr2) = + arrUsage (App (Lam b expr2) expr1) + +arrUsage (Let (Rec bnds) expr) = + let + t1 = foldr combineArrayUsage Prim (map bindType bnds) + t2 = arrUsage expr + in if isArrayUsage t1 then Array else t2 + +arrUsage (Case expr b alts) = + let + t1 = arrUsage expr + t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts) + in scanType [t1, t2] + +arrUsage (Note n expr) = + arrUsage expr + +arrUsage (Type t) = + typeArrayUsage t + +bindType (b, expr) = + let + bT = varArrayUsage b + exprT = arrUsage expr + in case (bT, exprT) of + (Array, _) -> Array + _ -> exprT + +scanType:: [ArrayUsage] -> ArrayUsage +scanType [t] = t +scanType (Array:ts) = Array +scanType (_:ts) = scanType ts + + + +-- the code expression represents a built-in function which generates +-- an array +isArrayGen:: CoreExpr -> Bool +isArrayGen _ = + panic "PArrAnal: isArrayGen: not yet implemented" + +isArrayCon:: CoreExpr -> Bool +isArrayCon _ = + panic "PArrAnal: isArrayCon: not yet implemented" + +markScalarExprs:: [CoreBind] -> [CoreBind] +markScalarExprs _ = + panic "PArrAnal.markScalarExprs: not implemented yet" + + +varArrayUsage:: Id -> ArrayUsage +varArrayUsage = + panic "PArrAnal.varArrayUsage: not yet implented" + +litArrayUsage:: Literal -> ArrayUsage +litArrayUsage = + panic "PArrAnal.litArrayUsage: not yet implented" + + +typeArrayUsage:: Type -> ArrayUsage +typeArrayUsage (TyVarTy tvar) = + PolyExpr (tIdFun tvar) +typeArrayUsage (AppTy _ _) = + panic "PArrAnal.typeArrayUsage: AppTy case not yet implemented" +typeArrayUsage (TyConApp tc tcargs) = + let + tcargsAU = map typeArrayUsage tcargs + tcCombine = foldr combineArrayUsage Prim tcargsAU + in auCon tcCombine +typeArrayUsage t@(SourceTy _) = + pprPanic "PArrAnal.typeArrayUsage: encountered 'SourceType - shouldn't be here!" + (ppr t) + + +combineArrayUsage:: ArrayUsage -> ArrayUsage -> ArrayUsage +combineArrayUsage Array _ = Array +combineArrayUsage _ Array = Array +combineArrayUsage (PolyExpr f1) (PolyExpr f2) = + PolyExpr f' + where + f' var = + let + f1lookup = f1 var + f2lookup = f2 var + in + case (f1lookup, f2lookup) of + (Nothing, _) -> f2lookup + (_, Nothing) -> f1lookup + (Just f1', Just f2') -> Just ( \e -> (combineArrayUsage (f1' e) (f2' e))) +combineArrayUsage (PolyFun f) (PolyExpr g) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage (PolyExpr g) (PolyFun f) = + panic ("PArrAnal.typeArrayUsage: PolyFun as argument in data" ++ + " constructor - should not (?) happen\n") +combineArrayUsage NonPrim _ = NonPrim +combineArrayUsage _ NonPrim = NonPrim +combineArrayUsage Prim Prim = Prim + + +isArrayUsage:: ArrayUsage -> Bool +isArrayUsage Array = True +isArrayUsage _ = False + +-- Functions to serve as arguments for PolyExpr +-- --------------------------------------------- + +tIdFun:: Var -> Var -> Maybe (ArrayUsage -> ArrayUsage) +tIdFun t tcomp = + if t == tcomp then + Just auId + else + Nothing + +-- Functions to serve as argument for PolyFun +-- ------------------------------------------- + +auId:: ArrayUsage -> ArrayUsage +auId = id + +auCon:: ArrayUsage -> ArrayUsage +auCon Prim = NonPrim +auCon (PolyExpr f) = PolyExpr f' + where f' v = case f v of + Nothing -> Nothing + Just g -> Just ( \e -> (auCon (g e))) +auCon (PolyFun f) = PolyFun (auCon . f) +auCon _ = Array + +-- traversal of Core expressions +-- ----------------------------- + +-- FIXME: implement + diff --git a/ghc/compiler/ndpFlatten/TODO b/ghc/compiler/ndpFlatten/TODO new file mode 100644 index 0000000..e596609 --- /dev/null +++ b/ghc/compiler/ndpFlatten/TODO @@ -0,0 +1,202 @@ + TODO List for Flattening Support in GHC -*-text-*- + ======================================= + +Middle-End Related +~~~~~~~~~~~~~~~~~~ + +Flattening Transformation +~~~~~~~~~~~~~~~~~~~~~~~~~ + +* Complete and test + +* Complete the analysis + +* Type transformation: The idea solution would probably be if we can add some + generic machinery, so that we can define all the rules for handling the type + and value transformations in a library. (The PrelPArr for WayNDP.) + + +Library Related +~~~~~~~~~~~~~~~ + +* Problem with re-exporting PrelPArr from Prelude is that it would also be + visible when -pparr is not given. There should be a mechanism to implicitly + import more than one module (like PERVASIVE modules in M3) + +* We need a PrelPArr-like library for when flattening is used, too. In fact, + we need some library routines that are on the level of merely vectorised + code (eg, for the dummy default vectors), and then, all the `PArrays' stuff + implementing fast unboxed arrays and fusion. + +* Enum is a problem. Ideally, we would like `enumFromToP' and + `enumFromThenToP' to be members of `Enum'. On the other hand, we really do + not want to change `Enum'. The solution for the moment is to define + + enumFromTo x y = mapP toEnum [:fromEnum x .. fromEnum y:] + enumFromThenTo x y z = mapP toEnum [:fromEnum x, fromEnum y .. fromEnum z:] + + like the Haskell Report does for the list versions. This is hopefully + efficient enough as array fusion should fold the two traversals into one. + [DONE] + + +DOCU that should go into the Commentary +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type constructor [::] +------------------------- + +The array type constructor [::] is quite similar to [] (list constructor) in +that GHC has to know about it (in TysWiredIn); however, there are some +differences: + +* [::] is an abstract type, whereas [] is not + +* if flattening is switched on, all occurences of the type are actually + removed by appropriate program transformations. + +The module PrelPArr that actually implements nested parallel arrays. [::] is +eliminated only if in addition to array support, flattening is activated. It +is just an option rather than the only method to implement those arrays. + + Flags: -fparr -- syntactic support for parallel arrays (via `PrelPArr') + * Dynamic hsc option; can be reversed with -fno-parr + -fflatten -- flattening transformation + * Static hsc option + -ndp -- this a way option, which implies -fparr and -fflatten + (way options are handled by the driver and are not + directly seen by hsc) + -ddump-vect -- dump Core after vectorisation + * Dynamic hsc option + +* PrelPArr implements array variants of the Prelude list functions plus some + extra functions (also, some list functions (eg, those generating infinite + lists) have been left out. + +* prelude/PrelNames has been extended with all the names from PrelPArr that + need to be known inside the compiler + +* The variable GhcSupportsPArr, which can be set in build.mk decides whether + `PrelPArr' is to be compiled or not. (We probably need to supress compiling + PrelPArr in WayNDP, or rather replace it with a different PrelPArr.) + +* Say something about `TysWiredIn.parrTyCon' as soon as we know how it + actually works... + +Parser and AST Notes: +- Parser and AST is quite straight forward. Essentially, the list cases + duplicated with a name containing `PArr' or `parr' and modified to fit the + slightly different semantics (ie, finite length, strict). +- The value and pattern `[::]' is an empty explicit parallel array (ie, + something of the form `ExplicitPArr ty []' in the AST). This is in contrast + to lists, which use the nil-constructor instead. In the case of parallel + arrays, using a constructor would be rather awkward, as it is not a + constructor-based type. +- Thus, array patterns have the general form `[:p1, p2, ..., pn:]', where n >= + 0. Thus, two array patterns overlap iff they have the same length. +- The type constructor for parallel is internally represented as a + `TyCon.AlgTyCon' with a wired in definition in `TysWiredIn'. + +Desugarer Notes: +- Desugaring of patterns involving parallel arrays: + * In Match.tidy1, we use fake array constructors; ie, any pattern `[:p1, ..., + pn:]' is replaces by the expression `MkPArr p1 ... pn', where + `MkPArr' is the n-ary array constructor. These constructors are fake, + because they are never used to actually represent array values; in fact, + they are removed again before pattern compilation is finished. However, + the use of these fake constructors implies that we need not modify large + parts of the machinery of the pattern matching compiler, as array patterns + are handled like any other constructor pattern. + * Check.simplify_pat introduces the same fake constructors as Match.tidy1 + and removed again by Check.make_con. + * In DsUtils.mkCoAlgCaseMatchResult, we catch the case of array patterns and + generate code as the following example illustrates, where the LHS is the + code that would be produced if array construtors would really exist: + + case v of pa { + MkPArr1 x1 -> e1 + MkPArr2 x2 x3 x4 -> e2 + DFT -> e3 + } + + => + + case lengthP v of + Int# i# -> + case i# of l { + 1 -> let x1 = v!:0 in e1 + 3 -> let x2 = v!:0; x2 = v!:1; x3 = v!:2 in e2 + DFT -> e3 + } + * The desugaring of array comprehensions is in `DsListComp', but follows + rules that are different from that for translating list comprehensions. + Denotationally, it boils down to the same, but the operational + requirements for an efficient implementation of array comprehensions are + rather different. + + [:e | qss:] = <<[:e | qss:]>> () [:():] + + <<[:e' | :]>> pa ea = mapP (\pa -> e') ea + <<[:e' | b , qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) + <<[:e' | p <- e, qs:]>> pa ea = + let ef = filterP (\x -> case x of {p -> True; _ -> False}) e + in + <<[:e' | qs:]>> (pa, p) (crossP ea ef) + <<[:e' | let ds, qs:]>> pa ea = + <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) + (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea) + where + {x_1, ..., x_n} = DV (ds) -- Defined Variables + <<[:e' | qs | qss:]>> pa ea = + <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) + (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) + where + {x_1, ..., x_n} = DV (qs) + + Moreover, we have + + crossP :: [:a:] -> [:b:] -> [:(a, b):] + crossP a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + x1 = concatP $ mapP (replicateP len2) a1 + x2 = concatP $ replicateP len1 a2 + in + zipP x1 x2 + + For a more efficient implementation of `crossP', see `PrelPArr'. + + Optimisations: + - In the `p <- e' rule, if `pa = ()', drop it and simplify the `crossP ea + e' to `e'. + - We assume that fusion will optimise sequences of array processing + combinators. + - Do we want to have the following function? + + mapFilterP :: (a -> Maybe b) -> [:a:] -> [:b:] + + Even with fusion `(mapP (\p -> e) . filterP (\p -> b))' may still result + in redundant pattern matching operations. (Let's wait with this until + we have seen what the Simplifier does to the generated code.) + +Flattening Notes: +* The story about getting access to all the names like "fst" etc that we need + to generate during flattening is quite involved. To have a reasonable + chance to get at the stuff, we need to put flattening inbetween the + desugarer and the simplifier as an extra pass in HscMain.hscMain. After + that point, the persistent compiler state is zapped (for heap space + reduction reasons, I guess) and nothing remains of the imported interfaces + in one shot mode. + + Moreover, to get the Ids that we need into the type environment, we need to + force the renamer to include them. This is done in + RnEnv.getImplicitModuleFVs, which computes all implicitly imported names. + We let it add the names from FlattenInfo.namesNeededForFlattening. + + Given all these arrangements, FlattenMonad can obtain the needed Ids from + the persistent compiler state without much further hassle. + + [It might be worthwhile to document in the non-Flattening part of the + Commentary that the persistent compiler state is zapped after desugaring and + how the free variables determined by the renamer imply which names are + imported.] diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index dfc3945..06fe82f 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -23,7 +23,7 @@ module Lex ( -- Monad for parser Token(..), lexer, ParseResult(..), PState(..), - checkVersion, + checkVersion, ExtFlags(..), mkPState, StringBuffer, P, thenP, thenP_, returnP, mapP, failP, failMsgP, @@ -55,6 +55,7 @@ import GlaExts import Ctype import Char ( chr, ord ) import PrelRead ( readRational__ ) -- Glasgow non-std +import PrelBits ( Bits(..) ) -- non-std \end{code} %************************************************************************ @@ -192,6 +193,8 @@ data Token | ITccurlybar -- |}, for type applications | ITvccurly | ITobrack + | ITopabrack -- [:, for parallel arrays with -fparr + | ITcpabrack -- :], for parallel arrays with -fparr | ITcbrack | IToparen | ITcparen @@ -387,7 +390,8 @@ The lexical analyser Lexer state: - - (glaexts) lexing an interface file or -fglasgow-exts + - (exts) lexing a source with extensions, eg, an interface file or + with -fglasgow-exts - (bol) pointer to beginning of line (for column calculations) - (buf) pointer to beginning of token - (buf) pointer to current char @@ -397,7 +401,7 @@ Lexer state: lexer :: (Token -> P a) -> P a lexer cont buf s@(PState{ loc = loc, - glasgow_exts = glaexts, + extsBitmap = exts, bol = bol, atbol = atbol, context = ctx @@ -444,7 +448,7 @@ lexer cont buf s@(PState{ (map toUpper (lexemeToString buf2)) in case lookupUFM pragmaKeywordsFM lexeme of -- ignore RULES pragmas when -fglasgow-exts is off - Just ITrules_prag | not (flag glaexts) -> + Just ITrules_prag | not (glaExtsEnabled exts) -> skip_to_end (stepOnBy# buf 2#) s' Just ITline_prag -> line_prag skip_to_end buf2 s' @@ -481,7 +485,7 @@ lexer cont buf s@(PState{ atbol = atbol} is_a_token | atbol /=# 0# = lexBOL cont buf s' - | otherwise = lexToken cont glaexts buf s' + | otherwise = lexToken cont exts buf s' -- {-# LINE .. #-} pragmas. yeuch. line_prag cont buf s@PState{loc=loc} = @@ -541,7 +545,7 @@ skipNestedComment' orig_loc cont buf = loop buf lexBOL :: (Token -> P a) -> P a lexBOL cont buf s@(PState{ loc = loc, - glasgow_exts = glaexts, + extsBitmap = exts, bol = bol, atbol = atbol, context = ctx @@ -553,7 +557,7 @@ lexBOL cont buf s@(PState{ --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $ cont ITsemi buf s{atbol = 0#} else - lexToken cont glaexts buf s{atbol = 0#} + lexToken cont exts buf s{atbol = 0#} where col = currentIndex# buf -# bol @@ -572,18 +576,21 @@ lexBOL cont buf s@(PState{ lexToken :: (Token -> P a) -> Int# -> P a -lexToken cont glaexts buf = +lexToken cont exts buf = -- trace "lexToken" $ case currentChar# buf of -- special symbols ---------------------------------------------------- - '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'# + '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# -> cont IToubxparen (setCurrentPos# buf 2#) | otherwise -> cont IToparen (incLexeme buf) ')'# -> cont ITcparen (incLexeme buf) - '['# -> cont ITobrack (incLexeme buf) + '['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# -> + cont ITopabrack (setCurrentPos# buf 2#) + | otherwise -> + cont ITobrack (incLexeme buf) ']'# -> cont ITcbrack (incLexeme buf) ','# -> cont ITcomma (incLexeme buf) ';'# -> cont ITsemi (incLexeme buf) @@ -592,26 +599,31 @@ lexToken cont glaexts buf = (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'} _ -> lexError "too many '}'s" buf s '|'# -> case lookAhead# buf 1# of - '}'# | flag glaexts -> cont ITccurlybar - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + '}'# | glaExtsEnabled exts -> cont ITccurlybar + (setCurrentPos# buf 2#) + _ -> lex_sym cont (incLexeme buf) + ':'# -> case lookAhead# buf 1# of + ']'# | parrEnabled exts -> cont ITcpabrack + (setCurrentPos# buf 2#) + _ -> lex_sym cont (incLexeme buf) '#'# -> case lookAhead# buf 1# of - ')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#) + ')'# | glaExtsEnabled exts + -> cont ITcubxparen (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of '}'# -> cont ITclose_prag (setCurrentPos# buf 3#) _ -> lex_sym cont (incLexeme buf) _ -> lex_sym cont (incLexeme buf) - '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'# + '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'# -> lex_cstring cont (setCurrentPos# buf 2#) | otherwise -> cont ITbackquote (incLexeme buf) - '{'# -> -- look for "{-##" special iface pragma + '{'# -> -- look for "{-##" special iface pragma -- for Emacs: -} case lookAhead# buf 1# of - '|'# | flag glaexts + '|'# | glaExtsEnabled exts -> cont ITocurlybar (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of '#'# -> case lookAhead# buf 3# of @@ -626,11 +638,11 @@ lexToken cont glaexts buf = _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) -- strings/characters ------------------------------------------------- - '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf) - '\''# -> lex_char (char_end cont) glaexts (incLexeme buf) + '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf) + '\''# -> lex_char (char_end cont) exts (incLexeme buf) -- strictness and cpr pragmas and __scc treated specially. - '_'# | flag glaexts -> + '_'# | glaExtsEnabled exts -> case lookAhead# buf 1# of '_'# -> case lookAhead# buf 2# of 'S'# -> @@ -642,15 +654,15 @@ lexToken cont glaexts buf = 's'# -> case prefixMatch (stepOnBy# buf 3#) "cc" of Just buf' -> lex_scc cont (stepOverLexeme buf') - Nothing -> lex_id cont glaexts buf - _ -> lex_id cont glaexts buf - _ -> lex_id cont glaexts buf + Nothing -> lex_id cont exts buf + _ -> lex_id cont exts buf + _ -> lex_id cont exts buf -- Hexadecimal and octal constants '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2 - -> readNum (after_lexnum cont glaexts) buf' is_hexdigit 16 hex + -> readNum (after_lexnum cont exts) buf' is_hexdigit 16 hex | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2 - -> readNum (after_lexnum cont glaexts) buf' is_octdigit 8 oct_or_dec + -> readNum (after_lexnum cont exts) buf' is_octdigit 8 oct_or_dec where ch = lookAhead# buf 1# ch2 = lookAhead# buf 2# buf' = setCurrentPos# buf 2# @@ -662,14 +674,14 @@ lexToken cont glaexts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) - '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> + '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> lex_ip ITdupipvarid cont (incLexeme buf) - '%'# | flag glaexts && is_lower (lookAhead# buf 1#) -> + '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> lex_ip ITsplitipvarid cont (incLexeme buf) - c | is_digit c -> lex_num cont glaexts 0 buf + c | is_digit c -> lex_num cont exts 0 buf | is_symbol c -> lex_sym cont buf - | is_upper c -> lex_con cont glaexts buf - | is_ident c -> lex_id cont glaexts buf + | is_upper c -> lex_con cont exts buf + | is_ident c -> lex_id cont exts buf | otherwise -> lexError "illegal character" buf -- Int# is unlifted, and therefore faster than Bool for flags. @@ -693,51 +705,51 @@ lex_prag cont buf ------------------------------------------------------------------------------- -- Strings & Chars -lex_string cont glaexts s buf +lex_string cont exts s buf = case currentChar# buf of '"'#{-"-} -> let buf' = incLexeme buf s' = mkFastStringNarrow (map chr (reverse s)) in case currentChar# buf' of - '#'# | flag glaexts -> if all (<= 0xFF) s + '#'# | glaExtsEnabled exts -> if all (<= 0xFF) s then cont (ITprimstring s') (incLexeme buf') else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf' _ -> cont (ITstring s') buf' -- ignore \& in a string, deal with string gaps '\\'# | next_ch `eqChar#` '&'# - -> lex_string cont glaexts s buf' + -> lex_string cont exts s buf' | is_space next_ch - -> lex_stringgap cont glaexts s (incLexeme buf) + -> lex_stringgap cont exts s (incLexeme buf) where next_ch = lookAhead# buf 1# buf' = setCurrentPos# buf 2# - _ -> lex_char (lex_next_string cont s) glaexts buf + _ -> lex_char (lex_next_string cont s) exts buf -lex_stringgap cont glaexts s buf +lex_stringgap cont exts s buf = let buf' = incLexeme buf in case currentChar# buf of - '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont glaexts s buf' + '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf' st{loc = incSrcLine loc} - '\\'# -> lex_string cont glaexts s buf' - c | is_space c -> lex_stringgap cont glaexts s buf' + '\\'# -> lex_string cont exts s buf' + c | is_space c -> lex_stringgap cont exts s buf' other -> charError buf' -lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf +lex_next_string cont s exts c buf = lex_string cont exts (c:s) buf lex_char :: (Int# -> Int -> P a) -> Int# -> P a -lex_char cont glaexts buf +lex_char cont exts buf = case currentChar# buf of - '\\'# -> lex_escape (cont glaexts) (incLexeme buf) - c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf) + '\\'# -> lex_escape (cont exts) (incLexeme buf) + c | is_any c -> cont exts (I# (ord# c)) (incLexeme buf) other -> charError buf -char_end cont glaexts c buf +char_end cont exts c buf = case currentChar# buf of '\''# -> let buf' = incLexeme buf in case currentChar# buf' of - '#'# | flag glaexts + '#'# | glaExtsEnabled exts -> cont (ITprimchar c) (incLexeme buf') _ -> cont (ITchar c) buf' _ -> charError buf @@ -892,7 +904,7 @@ lex_scc cont buf = -- Numbers lex_num :: (Token -> P a) -> Int# -> Integer -> P a -lex_num cont glaexts acc buf = +lex_num cont exts acc buf = case scanNumLit acc buf of (acc',buf') -> case currentChar# buf' of @@ -919,18 +931,18 @@ lex_num cont glaexts acc buf = v = readRational__ (lexemeToString l) in case currentChar# l of -- glasgow exts only - '#'# | flag glaexts -> let l' = incLexeme l in + '#'# | glaExtsEnabled exts -> let l' = incLexeme l in case currentChar# l' of '#'# -> cont (ITprimdouble v) (incLexeme l') _ -> cont (ITprimfloat v) l' _ -> cont (ITrational v) l - _ -> after_lexnum cont glaexts acc' buf' + _ -> after_lexnum cont exts acc' buf' -after_lexnum cont glaexts i buf +after_lexnum cont exts i buf = case currentChar# buf of - '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf) - _ -> cont (ITinteger i) buf + '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme buf) + _ -> cont (ITinteger i) buf ----------------------------------------------------------------------------- -- C "literal literal"s (i.e. things like ``NULL'', ``stdout'' etc.) @@ -953,11 +965,11 @@ lex_ip ip_constr cont buf = buf' -> cont (ip_constr (tailFS lexeme)) buf' where lexeme = lexemeToFastString buf' -lex_id cont glaexts buf = +lex_id cont exts buf = let buf1 = expandWhile# is_ident buf in seq buf1 $ - case (if flag glaexts + case (if glaExtsEnabled exts then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes else buf1) of { buf' -> @@ -970,7 +982,7 @@ lex_id cont glaexts buf = let var_token = cont (ITvarid lexeme) buf' in - if not (flag glaexts) + if not (glaExtsEnabled exts) then var_token else @@ -996,11 +1008,11 @@ lex_sym cont buf = -- The argument buf is the StringBuffer representing the lexeme -- identified so far, where the next character is upper-case. -lex_con cont glaexts buf = +lex_con cont exts buf = -- trace ("con: "{-++unpackFS lexeme-}) $ let empty_buf = stepOverLexeme buf in - case expandWhile# is_ident empty_buf of { buf1 -> - case slurp_trailing_hashes buf1 glaexts of { con_buf -> + case expandWhile# is_ident empty_buf of { buf1 -> + case slurp_trailing_hashes buf1 exts of { con_buf -> let all_buf = mergeLexemes buf con_buf @@ -1014,13 +1026,13 @@ lex_con cont glaexts buf = in case currentChar# all_buf of - '.'# -> maybe_qualified cont glaexts all_lexeme + '.'# -> maybe_qualified cont exts all_lexeme (incLexeme all_buf) just_a_conid _ -> just_a_conid }} -maybe_qualified cont glaexts mod buf just_a_conid = +maybe_qualified cont exts mod buf just_a_conid = -- trace ("qid: "{-++unpackFS lexeme-}) $ case currentChar# buf of '['# -> -- Special case for [] @@ -1031,7 +1043,7 @@ maybe_qualified cont glaexts mod buf just_a_conid = '('# -> -- Special case for (,,,) -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)" case lookAhead# buf 1# of - '#'# | flag glaexts -> case lookAhead# buf 2# of + '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) just_a_conid _ -> just_a_conid @@ -1041,14 +1053,14 @@ maybe_qualified cont glaexts mod buf just_a_conid = '-'# -> case lookAhead# buf 1# of '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#) - _ -> lex_id3 cont glaexts mod buf just_a_conid + _ -> lex_id3 cont exts mod buf just_a_conid - _ -> lex_id3 cont glaexts mod buf just_a_conid + _ -> lex_id3 cont exts mod buf just_a_conid -lex_id3 cont glaexts mod buf just_a_conid +lex_id3 cont exts mod buf just_a_conid | is_upper (currentChar# buf) = - lex_con cont glaexts buf + lex_con cont exts buf | is_symbol (currentChar# buf) = let @@ -1075,7 +1087,7 @@ lex_id3 cont glaexts mod buf just_a_conid then just_a_conid else - case slurp_trailing_hashes buf1 glaexts of { buf' -> + case slurp_trailing_hashes buf1 exts of { buf' -> let lexeme = lexemeToFastString buf' @@ -1091,9 +1103,9 @@ lex_id3 cont glaexts mod buf just_a_conid -> just_a_conid -- avoid M.where etc. }}} -slurp_trailing_hashes buf glaexts - | flag glaexts = expandWhile# (`eqChar#` '#'#) buf - | otherwise = buf +slurp_trailing_hashes buf exts + | glaExtsEnabled exts = expandWhile# (`eqChar#` '#'#) buf + | otherwise = buf mk_var_token pk_str @@ -1204,11 +1216,11 @@ data ParseResult a | PFailed Message data PState = PState { - loc :: SrcLoc, - glasgow_exts :: Int#, - bol :: Int#, - atbol :: Int#, - context :: [LayoutContext] + loc :: SrcLoc, + extsBitmap :: Int#, -- bitmap that determines permitted extensions + bol :: Int#, + atbol :: Int#, + context :: [LayoutContext] } type P a = StringBuffer -- Input string @@ -1356,6 +1368,48 @@ checkVersion mb@Nothing buf s@(PState{loc = loc}) | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s () | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-}) + +-- for reasons of efficiency, flags indicating language extensions (eg, +-- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed +-- integer + +glaExtsBit, ffiBit, parrBit :: Int +glaExtsBit = 0 +ffiBit = 1 -- FIXME: not used yet; still part of `glaExtsBit' +parrBit = 2 + +glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool +glaExtsEnabled flags = testBit (I# flags) glaExtsBit +ffiEnabled flags = testBit (I# flags) ffiBit +parrEnabled flags = testBit (I# flags) parrBit + +-- convenient record-based bitmap for the interface to the rest of the world +-- +data ExtFlags = ExtFlags { + glasgowExtsEF :: Bool, +-- ffiEF :: Bool, -- commented out to avoid warnings + parrEF :: Bool -- while not used yet + } + +-- create a parse state +-- +mkPState :: SrcLoc -> ExtFlags -> PState +mkPState loc exts = PState { + loc = loc, + extsBitmap = case bitmap of {I# bits -> bits}, + bol = 0#, + atbol = 1#, + context = [] + } + where + bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts +-- .|. ffiBit `setBitIf` ffiEF exts + .|. parrBit `setBitIf` parrEF exts + -- + b `setBitIf` cond | cond = bit b + | otherwise = 0 + + ----------------------------------------------------------------- ifaceParseErr :: StringBuffer -> SrcLoc -> Message diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 8d57937..73f31fa 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -226,6 +226,8 @@ checkPat e [] = case e of HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (ListPatIn ps) + ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (PArrPatIn ps) ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (TuplePatIn ps b) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index e3f305f..ec7af29 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.83 2002/02/04 03:40:32 chak Exp $ +$Id: Parser.y,v 1.84 2002/02/11 08:20:44 chak Exp $ Haskell grammar. @@ -18,9 +18,9 @@ import RdrHsSyn import Lex import ParseUtil import RdrName -import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR, - tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR - ) +import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, + listTyCon_RDR, parrTyCon_RDR, tupleTyCon_RDR, + unitCon_RDR, nilCon_RDR, tupleCon_RDR ) import ForeignCall ( Safety(..), CExportSpec(..), CCallSpec(..), CCallConv(..), CCallTarget(..), defaultCCallConv, DNCallSpec(..) ) @@ -175,6 +175,8 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] vccurly { ITvccurly } -- virtual close curly (from layout) '[' { ITobrack } ']' { ITcbrack } + '[:' { ITopabrack } + ':]' { ITcpabrack } '(' { IToparen } ')' { ITcparen } '(#' { IToubxparen } @@ -662,6 +664,7 @@ atype :: { RdrNameHsType } | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) } | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) } | '[' type ']' { HsListTy $2 } + | '[:' type ':]' { HsPArrTy $2 } | '(' ctype ')' { $2 } -- Generics | INTEGER { HsNumTy $1 } @@ -883,6 +886,7 @@ aexp1 :: { RdrNameHsExpr } | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { $2 } + | '[:' parr ':]' { $2 } | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) } | '(' qopm infixexp ')' { (SectionR $2 $3) } | qvar '@' aexp { EAsPat $1 $3 } @@ -932,6 +936,35 @@ quals :: { [RdrNameStmt] } | stmt { [$1] } ----------------------------------------------------------------------------- +-- Parallel array expressions + +-- The rules below are little bit contorted; see the list case for details. +-- Note that, in contrast to lists, we only have finite arithmetic sequences. +-- Moreover, we allow explicit arrays with no element (represented by the nil +-- constructor in the list case). + +parr :: { RdrNameHsExpr } + : { ExplicitPArr placeHolderType [] } + | exp { ExplicitPArr placeHolderType [$1] } + | lexps { ExplicitPArr placeHolderType + (reverse $1) } + | exp '..' exp { PArrSeqIn (FromTo $1 $3) } + | exp ',' exp '..' exp { PArrSeqIn (FromThenTo $1 $3 $5) } + | exp srcloc pquals {% let { + body [qs] = qs; + body qss = [ParStmt + (map reverse qss)]} + in + returnP $ + HsDo PArrComp + (reverse (ResultStmt $1 $2 + : body $3)) + $2 + } + +-- We are reusing `lexps' and `pquals' from the list case. + +----------------------------------------------------------------------------- -- Case alternatives altslist :: { [RdrNameMatch] } @@ -1047,6 +1080,7 @@ gtycon :: { RdrName } | '(' ')' { unitTyCon_RDR } | '(' '->' ')' { funTyCon_RDR } | '[' ']' { listTyCon_RDR } + | '[:' ':]' { parrTyCon_RDR } | '(' commas ')' { tupleTyCon_RDR $2 } gcon :: { RdrName } @@ -1054,6 +1088,7 @@ gcon :: { RdrName } | '[' ']' { nilCon_RDR } | '(' commas ')' { tupleCon_RDR $2 } | qcon { $1 } +-- the case of '[:' ':]' is part of the production `parr' var :: { RdrName } : varid { $1 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 7629070..5df53ae 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -143,6 +143,7 @@ extract_tys tys = foldr extract_ty [] tys extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsPArrTy ty) acc = extract_ty ty acc extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsPredTy p) acc = extract_pred p acc diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index be714d1..8a82330 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -148,7 +148,11 @@ knownKeyNames returnMName, failMName, fromRationalName, - + + -- not class methods, but overloaded (for parallel arrays) + enumFromToPName, + enumFromThenToPName, + deRefStablePtrName, newStablePtrName, bindIOName, @@ -171,6 +175,20 @@ knownKeyNames buildName, augmentName, + -- Parallel array operations + nullPName, + lengthPName, + replicatePName, + mapPName, + filterPName, + zipPName, + crossPName, + indexPName, + toPName, + bpermutePName, + bpermuteDftPName, + indexOfPName, + -- FFI primitive types that are not wired-in. int8TyConName, int16TyConName, @@ -190,7 +208,19 @@ knownKeyNames assertName, runSTRepName, printName, - splitIdName, fstIdName, sndIdName -- Used by splittery + splitName, fstName, sndName, -- Used by splittery + + -- Others (needed for flattening and not mentioned before) + andName, + orName, + eqCharName, + eqIntName, + eqFloatName, + eqDoubleName, + neqCharName, + neqIntName, + neqFloatName, + neqDoubleName ] \end{code} @@ -210,6 +240,7 @@ pREL_SHOW_Name = mkModuleName "PrelShow" pREL_READ_Name = mkModuleName "PrelRead" pREL_NUM_Name = mkModuleName "PrelNum" pREL_LIST_Name = mkModuleName "PrelList" +pREL_PARR_Name = mkModuleName "PrelPArr" pREL_TUP_Name = mkModuleName "PrelTup" pREL_PACK_Name = mkModuleName "PrelPack" pREL_CONC_Name = mkModuleName "PrelConc" @@ -364,8 +395,8 @@ nilDataConName = dataQual pREL_BASE_Name SLIT("[]") nilDataConKey consDataConName = dataQual pREL_BASE_Name SLIT(":") consDataConKey -- PrelTup -fstIdName = varQual pREL_TUP_Name SLIT("fst") fstIdKey -sndIdName = varQual pREL_TUP_Name SLIT("snd") sndIdKey +fstName = varQual pREL_TUP_Name SLIT("fst") fstIdKey +sndName = varQual pREL_TUP_Name SLIT("snd") sndIdKey -- Generics crossTyConName = tcQual pREL_BASE_Name SLIT(":*:") crossTyConKey @@ -377,14 +408,25 @@ genUnitTyConName = tcQual pREL_BASE_Name SLIT("Unit") genUnitTyConKey genUnitDataConName = dataQual pREL_BASE_Name SLIT("Unit") genUnitDataConKey -- Random PrelBase functions -unsafeCoerceName = varQual pREL_BASE_Name SLIT("unsafeCoerce") unsafeCoerceIdKey +unsafeCoerceName = varQual pREL_BASE_Name SLIT("unsafeCoerce") + unsafeCoerceIdKey otherwiseIdName = varQual pREL_BASE_Name SLIT("otherwise") otherwiseIdKey -appendName = varQual pREL_BASE_Name SLIT("++") appendIdKey -foldrName = varQual pREL_BASE_Name SLIT("foldr") foldrIdKey -mapName = varQual pREL_BASE_Name SLIT("map") mapIdKey -buildName = varQual pREL_BASE_Name SLIT("build") buildIdKey -augmentName = varQual pREL_BASE_Name SLIT("augment") augmentIdKey -eqStringName = varQual pREL_BASE_Name SLIT("eqString") eqStringIdKey +appendName = varQual pREL_BASE_Name SLIT("++") appendIdKey +foldrName = varQual pREL_BASE_Name SLIT("foldr") foldrIdKey +mapName = varQual pREL_BASE_Name SLIT("map") mapIdKey +buildName = varQual pREL_BASE_Name SLIT("build") buildIdKey +augmentName = varQual pREL_BASE_Name SLIT("augment") augmentIdKey +eqStringName = varQual pREL_BASE_Name SLIT("eqString") eqStringIdKey +andName = varQual pREL_BASE_Name SLIT("&&") andIdKey +orName = varQual pREL_BASE_Name SLIT("||") orIdKey +eqCharName = varQual pREL_GHC_Name SLIT("eqChar#") eqCharIdKey +eqIntName = varQual pREL_GHC_Name SLIT("==#") eqIntIdKey +eqFloatName = varQual pREL_GHC_Name SLIT("eqFloat#") eqFloatIdKey +eqDoubleName = varQual pREL_GHC_Name SLIT("==##") eqDoubleIdKey +neqCharName = varQual pREL_GHC_Name SLIT("neqChar#") neqCharIdKey +neqIntName = varQual pREL_GHC_Name SLIT("/=#") neqIntIdKey +neqFloatName = varQual pREL_GHC_Name SLIT("neqFloat#") neqFloatIdKey +neqDoubleName = varQual pREL_GHC_Name SLIT("/=##") neqDoubleIdKey -- Strings unpackCStringName = varQual pREL_BASE_Name SLIT("unpackCString#") unpackCStringIdKey @@ -455,6 +497,10 @@ enumFromToName = varQual pREL_ENUM_Name SLIT("enumFromTo") enumFromToClassOpK enumFromThenName = varQual pREL_ENUM_Name SLIT("enumFromThen") enumFromThenClassOpKey enumFromThenToName = varQual pREL_ENUM_Name SLIT("enumFromThenTo") enumFromThenToClassOpKey +-- Overloaded via Class Enum +enumFromToPName = varQual pREL_PARR_Name SLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual pREL_PARR_Name SLIT("enumFromThenToP") enumFromThenToPIdKey + -- Class Bounded boundedClassName = clsQual pREL_ENUM_Name SLIT("Bounded") boundedClassKey @@ -463,6 +509,23 @@ concatName = varQual pREL_LIST_Name SLIT("concat") concatIdKey filterName = varQual pREL_LIST_Name SLIT("filter") filterIdKey zipName = varQual pREL_LIST_Name SLIT("zip") zipIdKey +-- parallel array types and functions +parrTyConName = tcQual pREL_PARR_Name SLIT("[::]") parrTyConKey +parrDataConName = dataQual pREL_PARR_Name SLIT("PArr") parrDataConKey +nullPName = varQual pREL_PARR_Name SLIT("nullP") nullPIdKey +lengthPName = varQual pREL_PARR_Name SLIT("lengthP") lengthPIdKey +replicatePName = varQual pREL_PARR_Name SLIT("replicateP") replicatePIdKey +mapPName = varQual pREL_PARR_Name SLIT("mapP") mapPIdKey +filterPName = varQual pREL_PARR_Name SLIT("filterP") filterPIdKey +zipPName = varQual pREL_PARR_Name SLIT("zipP") zipPIdKey +crossPName = varQual pREL_PARR_Name SLIT("crossP") crossPIdKey +indexPName = varQual pREL_PARR_Name SLIT("!:") indexPIdKey +toPName = varQual pREL_PARR_Name SLIT("toP") toPIdKey +bpermutePName = varQual pREL_PARR_Name SLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual pREL_PARR_Name SLIT("bpermuteDftP") + bpermuteDftPIdKey +indexOfPName = varQual pREL_PARR_Name SLIT("indexOfP") indexOfPIdKey + -- IOBase things ioTyConName = tcQual pREL_IO_BASE_Name SLIT("IO") ioTyConKey ioDataConName = dataQual pREL_IO_BASE_Name SLIT("IO") ioDataConKey @@ -500,7 +563,7 @@ funPtrDataConName = dataQual pREL_PTR_Name SLIT("FunPtr") funPtrDataConKey byteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("ByteArray") byteArrayTyConKey mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") mutableByteArrayTyConKey --- Forign objects and weak pointers +-- Foreign objects and weak pointers foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey foreignPtrTyConName = tcQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrTyConKey @@ -516,7 +579,7 @@ getTagName = varQual pREL_GHC_Name SLIT("getTag#") getTagIdKey runSTRepName = varQual pREL_ST_Name SLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters -splitIdName = varQual pREL_SPLIT_Name SLIT("split") splitIdKey +splitName = varQual pREL_SPLIT_Name SLIT("split") splitIdKey \end{code} %************************************************************************ @@ -588,6 +651,7 @@ populate the occurrence list above. funTyCon_RDR = nameRdrName funTyConName nilCon_RDR = nameRdrName nilDataConName listTyCon_RDR = nameRdrName listTyConName +parrTyCon_RDR = nameRdrName parrTyConName ioTyCon_RDR = nameRdrName ioTyConName intTyCon_RDR = nameRdrName intTyConName eq_RDR = nameRdrName eqName @@ -767,6 +831,9 @@ crossTyConKey = mkPreludeTyConUnique 79 plusTyConKey = mkPreludeTyConUnique 80 genUnitTyConKey = mkPreludeTyConUnique 81 +-- Parallel array type constructor +parrTyConKey = mkPreludeTyConUnique 82 + unitTyConKey = mkTupleTyConUnique Boxed 0 \end{code} @@ -803,6 +870,9 @@ crossDataConKey = mkPreludeDataConUnique 20 inlDataConKey = mkPreludeDataConUnique 21 inrDataConKey = mkPreludeDataConUnique 22 genUnitDataConKey = mkPreludeDataConUnique 23 + +-- Data constructor for parallel arrays +parrDataConKey = mkPreludeDataConUnique 24 \end{code} %************************************************************************ @@ -868,6 +938,35 @@ runSTRepIdKey = mkPreludeMiscIdUnique 54 dollarMainKey = mkPreludeMiscIdUnique 55 runMainKey = mkPreludeMiscIdUnique 56 + +andIdKey = mkPreludeMiscIdUnique 57 +orIdKey = mkPreludeMiscIdUnique 58 +eqCharIdKey = mkPreludeMiscIdUnique 59 +eqIntIdKey = mkPreludeMiscIdUnique 60 +eqFloatIdKey = mkPreludeMiscIdUnique 61 +eqDoubleIdKey = mkPreludeMiscIdUnique 62 +neqCharIdKey = mkPreludeMiscIdUnique 63 +neqIntIdKey = mkPreludeMiscIdUnique 64 +neqFloatIdKey = mkPreludeMiscIdUnique 65 +neqDoubleIdKey = mkPreludeMiscIdUnique 66 + +-- NB: Currently a gap of four slots + +-- Parallel array functions +nullPIdKey = mkPreludeMiscIdUnique 70 +lengthPIdKey = mkPreludeMiscIdUnique 71 +replicatePIdKey = mkPreludeMiscIdUnique 72 +mapPIdKey = mkPreludeMiscIdUnique 73 +filterPIdKey = mkPreludeMiscIdUnique 74 +zipPIdKey = mkPreludeMiscIdUnique 75 +crossPIdKey = mkPreludeMiscIdUnique 76 +indexPIdKey = mkPreludeMiscIdUnique 77 +toPIdKey = mkPreludeMiscIdUnique 78 +enumFromToPIdKey = mkPreludeMiscIdUnique 79 +enumFromThenToPIdKey = mkPreludeMiscIdUnique 80 +bpermutePIdKey = mkPreludeMiscIdUnique 81 +bpermuteDftPIdKey = mkPreludeMiscIdUnique 82 +indexOfPIdKey = mkPreludeMiscIdUnique 83 \end{code} Certain class operations from Prelude classes. They get their own diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 18bf9a0..ade3426 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -69,7 +69,11 @@ module TysWiredIn ( voidTy, wordDataCon, wordTy, - wordTyCon + wordTyCon, + + -- parallel arrays + mkPArrTy, + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon ) where #include "HsVersions.h" @@ -88,18 +92,19 @@ import Name ( Name, nameRdrName, nameUnique, nameOccName, nameModule, mkWiredInName ) import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) import RdrName ( rdrNameOcc ) -import DataCon ( DataCon, mkDataCon, dataConId ) +import DataCon ( DataCon, mkDataCon, dataConId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, - mkTupleTyCon, mkAlgTyCon + mkTupleTyCon, mkAlgTyCon, tyConName ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) -import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, +import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, ThetaType ) -import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) +import Unique ( incrUnique, mkTupleTyConUnique, + mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames import Array @@ -130,6 +135,7 @@ data_tycons = genericTyCons ++ , intTyCon , integerTyCon , listTyCon + , parrTyCon , wordTyCon ] @@ -540,6 +546,100 @@ unitTy = mkTupleTy Boxed 0 [] \end{code} %************************************************************************ +%* * +\subsection[TysWiredIn-PArr]{The @[::]@ type} +%* * +%************************************************************************ + +Special syntax for parallel arrays needs some wired in definitions. + +\begin{code} +-- construct a type representing the application of the parallel array +-- constructor +-- +mkPArrTy :: Type -> Type +mkPArrTy ty = mkTyConApp parrTyCon [ty] + +-- represents the type constructor of parallel arrays +-- +-- * this must match the definition in `PrelPArr' +-- +-- NB: Although the constructor is given here, it will not be accessible in +-- user code as it is not in the environment of any compiled module except +-- `PrelPArr'. +-- +parrTyCon :: TyCon +parrTyCon = tycon + where + tycon = mkAlgTyCon + parrTyConName + kind + tyvars + [] -- No context + [(True, False)] + [parrDataCon] -- The constructor defined in `PrelPArr' + 1 -- The real definition has one constructor + [] -- No record selectors + DataTyCon + NonRecursive + genInfo + tyvars = alpha_tyvar + mod = nameModule parrTyConName + kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind + genInfo = mk_tc_gen_info mod (nameUnique parrTyConName) parrTyConName tycon + +parrDataCon :: DataCon +parrDataCon = pcDataCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [] -- context + [intPrimTy, -- 1st argument: Int# + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon + +-- check whether a type constructor is the constructor for parallel arrays +-- +isPArrTyCon :: TyCon -> Bool +isPArrTyCon tc = tyConName tc == parrTyConName + +-- fake array constructors +-- +-- * these constructors are never really used to represent array values; +-- however, they are very convenient during desugaring (and, in particular, +-- in the pattern matching compiler) to treat array pattern just like +-- yet another constructor pattern +-- +parrFakeCon :: Arity -> DataCon +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i = parrFakeConArr!i + +-- pre-defined set of constructors +-- +parrFakeConArr :: Array Int DataCon +parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) + | i <- [0..mAX_TUPLE_SIZE]] + +-- build a fake parallel array constructor for the given arity +-- +mkPArrFakeCon :: Int -> DataCon +mkPArrFakeCon arity = pcDataCon name [tyvar] [] tyvarTys parrTyCon + where + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar + nameStr = _PK_ ("MkPArr" ++ show arity) + name = mkWiredInName mod (mkOccFS dataName nameStr) uniq + uniq = mkPArrDataConUnique arity + mod = mkPrelModule pREL_PARR_Name + +-- checks whether a data constructor is a fake constructor for parallel arrays +-- +isPArrFakeCon :: DataCon -> Bool +isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) +\end{code} + +%************************************************************************ %* * \subsection{Wired In Type Constructors for Representation Types} %* * diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index b71b71f..cbeaeed 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,4 +1,4 @@ -{- Notes about the syntax of interface files +{- Notes about the syntax of interface files -*-haskell-*- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The header ~~~~~~~~~~ @@ -166,6 +166,8 @@ import FastString ( tailFS ) '|}' { ITccurlybar } -- special symbols '[' { ITobrack } ']' { ITcbrack } + '[:' { ITopabrack } + ':]' { ITcpabrack } '(' { IToparen } ')' { ITcparen } '(#' { IToubxparen } @@ -388,10 +390,10 @@ maybe_idinfo : {- empty -} { \_ -> [] } -} pragma :: { Maybe (ParseResult [HsIdInfo RdrName]) } -pragma : src_loc PRAGMA { Just (parseIdInfo $2 PState{ bol = 0#, atbol = 1#, - context = [], - glasgow_exts = 1#, - loc = $1 }) +pragma : src_loc PRAGMA { let exts = ExtFlags {glasgowExtsEF = True, + parrEF = True} + in + Just (parseIdInfo $2 (mkPState $1 exts)) } ----------------------------------------------------------------------------- @@ -401,10 +403,9 @@ pragma : src_loc PRAGMA { Just (parseIdInfo $2 PState{ bol = 0#, atbol = 1#, rules_and_deprecs_part :: { () -> ([RdrNameRuleDecl], IfaceDeprecs) } rules_and_deprecs_part : {- empty -} { \_ -> ([], Nothing) } - | src_loc PRAGMA { \_ -> case parseRules $2 PState{ bol = 0#, atbol = 1#, - context = [], - glasgow_exts = 1#, - loc = $1 } of + | src_loc PRAGMA { \_ -> let exts = ExtFlags {glasgowExtsEF = True, + parrEF = True} + in case parseRules $2 (mkPState $1 exts) of POk _ rds -> rds PFailed err -> pprPanic "Rules/Deprecations parse failed" err } @@ -557,6 +558,7 @@ atype : qtc_name { HsTyVar $1 } | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } | '[' type ']' { HsListTy $2 } + | '[:' type ':]' { HsPArrTy $2 } | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 } | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 } | '(' type ')' { $2 } @@ -586,6 +588,7 @@ tatype : qtc_name { HsTyVar $1 } | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } | '[' type ']' { HsListTy $2 } + | '[:' type ':]' { HsPArrTy $2 } | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 } | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 } | '(' type ')' { $2 } diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 331b0d0..d12aab9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,6 +10,7 @@ module RnEnv where -- Export everything import {-# SOURCE #-} RnHiFiles +import FlattenInfo ( namesNeededForFlattening ) import HsSyn import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, @@ -439,6 +440,9 @@ ubiquitousNames -- Add occurrences for very frequently used types. -- (e.g. we don't want to be bothered with making funTyCon a -- free var at every function application!) + `plusFV` + namesNeededForFlattening + -- this will be empty unless flattening is activated checkMain ghci_mode mod_name gbl_env -- LOOKUP main IF WE'RE IN MODULE Main @@ -447,7 +451,8 @@ checkMain ghci_mode mod_name gbl_env -- so that the type checker will find them -- -- We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others aren't + -- bona fide 'use', and should be recorded as such, but the others + -- aren't | mod_name /= mAIN_Name = returnRn (Nothing, emptyFVs, emptyFVs) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 846812d..cda67c4 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,18 +28,21 @@ import RnTypes ( rnHsTypeFVs ) import RnHiFiles ( lookupFixityRn ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange, inCharRange ) -import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), defaultFixity, negateFixity ) +import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), + defaultFixity, negateFixity ) import PrelNames ( hasKey, assertIdKey, eqClassName, foldrName, buildName, eqStringName, cCallableClassName, cReturnableClassName, monadClassName, enumClassName, ordClassName, - ratioDataConName, splitIdName, fstIdName, sndIdName, + ratioDataConName, splitName, fstName, sndName, ioDataConName, plusIntegerName, timesIntegerName, - assertErr_RDR - ) + assertErr_RDR, + replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, - floatPrimTyCon, doublePrimTyCon - ) + floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet @@ -132,6 +135,13 @@ rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) +rnPat (PArrPatIn pats) + = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> + returnRn (PArrPatIn patslist, + fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) + where + implicit_fvs = mkFVs [lengthPName, indexPName] + rnPat (TuplePatIn pats boxed) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) @@ -278,7 +288,7 @@ rnExpr (HsIPVar v) = newIPName v `thenRn` \ name -> let fvs = case name of - Linear _ -> mkFVs [splitIdName, fstIdName, sndIdName] + Linear _ -> mkFVs [splitName, fstName, sndName] Dupable _ -> emptyFVs in returnRn (HsIPVar name, fvs) @@ -381,16 +391,24 @@ rnExpr e@(HsDo do_or_lc stmts src_loc) } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) where - implicit_fvs = mkFVs [foldrName, buildName, monadClassName] + implicit_fvs = case do_or_lc of + PArrComp -> mkFVs [replicatePName, mapPName, filterPName, + falseDataConName, trueDataConName, crossPName, + zipPName] + _ -> mkFVs [foldrName, buildName, monadClassName] -- Monad stuff should not be necessary for a list comprehension -- but the typechecker looks up the bind and return Ids anyway -- Oh well. - rnExpr (ExplicitList _ exps) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) +rnExpr (ExplicitPArr _ exps) + = rnExprs exps `thenRn` \ (exps', fvs) -> + returnRn (ExplicitPArr placeHolderType exps', + fvs `addOneFV` toPName `addOneFV` parrTyCon_name) + rnExpr (ExplicitTuple exps boxity) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) @@ -449,6 +467,28 @@ rnExpr (ArithSeqIn seq) rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> returnRn (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) + +rnExpr (PArrSeqIn seq) + = rn_seq seq `thenRn` \ (new_seq, fvs) -> + returnRn (PArrSeqIn new_seq, + fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + where + + -- the parser shouldn't generate these two + -- + rn_seq (From _ ) = panic "RnExpr.rnExpr: Infinite parallel array!" + rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" + + rn_seq (FromTo expr1 expr2) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + rn_seq (FromThenTo expr1 expr2 expr3) + = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> + returnRn (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} These three are pattern syntax appearing in expressions. diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4eb5504..7c405de 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -559,15 +559,14 @@ readIface file_path Left io_error -> bale_out (text (show io_error)) ; Right contents -> - case parseIface contents init_parser_state of + case parseIface contents (mkPState loc exts) of POk _ iface -> returnRn (Right iface) PFailed err -> bale_out err } where - init_parser_state = PState{ bol = 0#, atbol = 1#, - context = [], - glasgow_exts = 1#, - loc = mkSrcLoc (mkFastString file_path) 1 } + exts = ExtFlags {glasgowExtsEF = True, + parrEF = True} + loc = mkSrcLoc (mkFastString file_path) 1 bale_out err = returnRn (Left (badIfaceFile file_path err)) \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 58a1acc..539a81e 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,7 +11,7 @@ module RnHsSyn where import HsSyn import HsCore import Class ( FunDep, DefMeth(..) ) -import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) +import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) @@ -56,9 +56,10 @@ type RenamedDeprecation = DeprecDecl Name These free-variable finders returns tycons and classes too. \begin{code} -charTyCon_name, listTyCon_name :: Name +charTyCon_name, listTyCon_name, parrTyCon_name :: Name charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon +parrTyCon_name = getName parrTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) @@ -75,6 +76,7 @@ extractHsTyNames ty where get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty + get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` get ty get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 61a14ef..2d544f5 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -115,6 +115,10 @@ rnHsType doc (HsListTy ty) = rnHsType doc ty `thenRn` \ ty' -> returnRn (HsListTy ty') +rnHsType doc (HsPArrTy ty) + = rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsPArrTy ty') + -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (HsTupleTy (HsTupCon _ boxity arity) tys) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index e8db094..598b985 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -8,8 +8,9 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), - DynFlags, DynFlag(..), dopt, dopt_CoreToDo +import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), + SimplifierMode(..), DynFlags, DynFlag(..), dopt, + dopt_CoreToDo ) import CoreSyn import CoreFVs ( ruleRhsFreeVars ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6039559..56fc0e3 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -16,8 +16,8 @@ import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy ) import TcMonad import TcUnify ( tcSub, tcGen, (<$>), - unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy - ) + unifyTauTy, unifyFunTy, unifyListTy, unifyPArrTy, + unifyTupleTy ) import BasicTypes ( RecFlag(..), isMarkedStrict ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, @@ -52,11 +52,12 @@ import Name ( Name ) import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( elemVarSet ) -import TysWiredIn ( boolTy, mkListTy, listTyCon ) +import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon ) import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, + enumFromToPName, enumFromThenToPName, thenMName, failMName, returnMName, ioTyConName ) import Outputable @@ -323,6 +324,15 @@ tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = tcAddErrCtxt (listCtxt expr) $ tcMonoExpr expr elt_ty +tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty + = unifyPArrTy res_ty `thenTc` \ elt_ty -> + mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) -> + returnTc (ExplicitPArr elt_ty exprs', plusLIEs lies) + where + tc_elt elt_ty expr + = tcAddErrCtxt (parrCtxt expr) $ + tcMonoExpr expr elt_ty + tcMonoExpr (ExplicitTuple exprs boxity) res_ty = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys -> mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty) @@ -541,6 +551,36 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty returnTc (ArithSeqOut (HsVar (instToId eft)) (FromThenTo expr1' expr2' expr3'), lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft) + +tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty + = tcAddErrCtxt (parrSeqCtxt in_expr) $ + unifyPArrTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcLookupGlobalId enumFromToPName `thenNF_Tc` \ sel_id -> + newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ enum_from_to -> + + returnTc (PArrSeqOut (HsVar (instToId enum_from_to)) + (FromTo expr1' expr2'), + lie1 `plusLIE` lie2 `plusLIE` unitLIE enum_from_to) + +tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty + = tcAddErrCtxt (parrSeqCtxt in_expr) $ + unifyPArrTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> + tcLookupGlobalId enumFromThenToPName `thenNF_Tc` \ sel_id -> + newMethod (PArrSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ eft -> + + returnTc (PArrSeqOut (HsVar (instToId eft)) + (FromThenTo expr1' expr2' expr3'), + lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` unitLIE eft) + +tcMonoExpr (PArrSeqIn _) _ + = panic "TcExpr.tcMonoExpr: Infinite parallel array!" + -- the parser shouldn't have generated it and the renamer shouldn't have + -- let it through \end{code} %************************************************************************ @@ -688,6 +728,27 @@ tcExpr_id expr = newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> %************************************************************************ \begin{code} +-- I don't like this lumping together of do expression and list/array +-- comprehensions; creating the monad instances is entirely pointless in the +-- latter case; I'll leave the list case as it is for the moment, but handle +-- arrays extra (would be better to handle arrays and lists together, though) +-- -=chak +-- +tcDoStmts PArrComp stmts src_loc res_ty + = + ASSERT( not (null stmts) ) + tcAddSrcLoc src_loc $ + + unifyPArrTy res_ty `thenTc` \elt_ty -> + let tc_ty = mkTyConTy parrTyCon + m_ty = (mkPArrTy, elt_ty) + in + tcStmts (DoCtxt PArrComp) m_ty stmts `thenTc` \(stmts', stmts_lie) -> + returnTc (HsDoOut PArrComp stmts' + undefined undefined undefined -- don't touch! + res_ty src_loc, + stmts_lie) + tcDoStmts do_or_lc stmts src_loc res_ty = -- get the Monad and MonadZero classes -- create type consisting of a fresh monad tyvar @@ -697,10 +758,14 @@ tcDoStmts do_or_lc stmts src_loc res_ty -- If it's a comprehension we're dealing with, -- force it to be a list comprehension. -- (as of Haskell 98, monad comprehensions are no more.) + -- Similarily, array comprehensions must involve parallel arrays types + -- -=chak (case do_or_lc of ListComp -> unifyListTy res_ty `thenTc` \ elt_ty -> returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty)) + PArrComp -> panic "TcExpr.tcDoStmts: How did we get here?!?" + _ -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenNF_Tc` \ m_ty -> newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenTc_` @@ -874,6 +939,9 @@ Boring and alphabetical: arithSeqCtxt expr = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr) +parrSeqCtxt expr + = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr) + caseCtxt expr = hang (ptext SLIT("In the case expression:")) 4 (ppr expr) @@ -887,6 +955,9 @@ exprSigCtxt expr listCtxt expr = hang (ptext SLIT("In the list element:")) 4 (ppr expr) +parrCtxt expr + = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr) + predCtxt expr = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 2c8ce25..39661e4 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -54,7 +54,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, integerTy, - mkListTy, mkTupleTy, unitTy ) + mkListTy, mkPArrTy, mkTupleTy, unitTy ) import CoreSyn ( Expr ) import Var ( isId ) import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName ) @@ -161,6 +161,7 @@ outPatType (LazyPat pat) = outPatType pat outPatType (AsPat var pat) = idType var outPatType (ConPat _ ty _ _ _) = ty outPatType (ListPat ty _) = mkListTy ty +outPatType (PArrPat ty _) = mkPArrTy ty outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) outPatType (RecPat _ ty _ _ _) = ty outPatType (SigPat _ ty _) = ty @@ -190,6 +191,7 @@ collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat collectTypedPatBinders (SigPat pat _ _) = collectTypedPatBinders pat collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (PArrPat t pats) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats) collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields) @@ -493,6 +495,11 @@ zonkExpr (ExplicitList ty exprs) mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitList new_ty new_exprs) +zonkExpr (ExplicitPArr ty exprs) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> + returnNF_Tc (ExplicitPArr new_ty new_exprs) + zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs boxed) @@ -514,12 +521,18 @@ zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" +zonkExpr (PArrSeqIn _) = panic "zonkExpr:PArrSeqIn" zonkExpr (ArithSeqOut expr info) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkArithSeq info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) +zonkExpr (PArrSeqOut expr info) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkArithSeq info `thenNF_Tc` \ new_info -> + returnNF_Tc (PArrSeqOut new_expr new_info) + zonkExpr (HsCCall fun args may_gc is_casm result_ty) = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> @@ -667,6 +680,11 @@ zonkPat (ListPat ty pats) zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> returnNF_Tc (ListPat new_ty new_pats, ids) +zonkPat (PArrPat ty pats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (PArrPat new_ty new_pats, ids) + zonkPat (TuplePat pats boxed) = zonkPats pats `thenNF_Tc` \ (new_pats, ids) -> returnNF_Tc (TuplePat new_pats boxed, ids) diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index eb37c46..49ef3f9 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -1070,5 +1070,3 @@ nonBoxedPrimCCallErr clas inst_ty = hang (ptext SLIT("Unacceptable instance type for ccall-ish class")) 4 (pprClassPred clas [inst_ty]) \end{code} - - diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 11cb6bd..dceff86 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -659,6 +659,7 @@ data InstOrigin | PatOrigin RenamedPat | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc + | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:] | SignatureOrigin -- A dict created from a type signature | Rank2Origin -- A dict created when typechecking the argument @@ -715,6 +716,8 @@ pprInstLoc (orig, locn, ctxt) = hsep [ptext SLIT("the pattern"), quotes (ppr pat)] pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] + pp_orig (PArrSeqOrigin seq) + = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] pp_orig (SignatureOrigin) = ptext SLIT("a type signature") pp_orig (Rank2Origin) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 21d554d..1d33e94 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -49,7 +49,7 @@ import TyCon ( TyCon, isSynTyCon, tyConKind ) import Class ( classTyCon ) import Name ( Name ) import NameSet -import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) +import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) import Util ( lengthIs ) @@ -267,6 +267,10 @@ kcHsType (HsListTy ty) = kcLiftedType ty `thenTc` \ tau_ty -> returnTc liftedTypeKind +kcHsType (HsPArrTy ty) + = kcLiftedType ty `thenTc` \ tau_ty -> + returnTc liftedTypeKind + kcHsType (HsTupleTy (HsTupCon _ boxity _) tys) = mapTc kcTypeType tys `thenTc_` returnTc (case boxity of @@ -400,6 +404,10 @@ tc_type (HsListTy ty) = tc_type ty `thenTc` \ tau_ty -> returnTc (mkListTy tau_ty) +tc_type (HsPArrTy ty) + = tc_type ty `thenTc` \ tau_ty -> + returnTc (mkPArrTy tau_ty) + tc_type (HsTupleTy (HsTupCon _ boxity arity) tys) = ASSERT( tys `lengthIs` arity ) tc_types tys `thenTc` \ tau_tys -> diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 0c40272..51a04dd 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -27,8 +27,9 @@ import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar ) import TcType ( TcType, TcTyVar, TcSigmaType, mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe, isHoleTyVar, openTypeKind ) -import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyTupleTy, - mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn ) +import TcUnify ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy, + unifyTupleTy, mkCoercion, idCoercion, isIdCoercion, + (<$>), PatCoFn ) import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) import TysWiredIn ( stringTy ) @@ -159,7 +160,7 @@ tcPat tc_bndr (SigPatIn pat sig) pat_ty %************************************************************************ %* * -\subsection{Explicit lists and tuples} +\subsection{Explicit lists, parallel arrays, and tuples} %* * %************************************************************************ @@ -170,6 +171,12 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail) +tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty + = tcAddErrCtxt (patCtxt pat_in) $ + unifyPArrTy pat_ty `thenTc` \ elem_ty -> + tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail) + tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index ca9180f..edf0659 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -52,7 +52,7 @@ import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass, - splitIdName, fstIdName, sndIdName ) + splitName, fstName, sndName ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import TysWiredIn ( unitTy, pairTyCon ) @@ -1192,8 +1192,8 @@ split n split_id avail wanted returnNF_Tc (andMonoBindList binds', concat rhss') do_one rhs = tcGetUnique `thenNF_Tc` \ uniq -> - tcLookupGlobalId fstIdName `thenNF_Tc` \ fst_id -> - tcLookupGlobalId sndIdName `thenNF_Tc` \ snd_id -> + tcLookupGlobalId fstName `thenNF_Tc` \ fst_id -> + tcLookupGlobalId sndName `thenNF_Tc` \ snd_id -> let x = mkUserLocal occ uniq pair_ty loc in @@ -1416,7 +1416,7 @@ isAvailable avails wanted = lookupFM avails wanted addLinearAvailable :: Avails -> Avail -> Inst -> NF_TcM (Avails, [Inst]) addLinearAvailable avails avail wanted | need_split avail - = tcLookupGlobalId splitIdName `thenNF_Tc` \ split_id -> + = tcLookupGlobalId splitName `thenNF_Tc` \ split_id -> newMethodAtLoc (instLoc wanted) split_id [linearInstType wanted] `thenNF_Tc` \ (split_inst,_) -> returnNF_Tc (addToFM avails wanted (Linear 2 split_inst avail), [split_inst]) diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 8ee07bc..56ae764 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -11,7 +11,7 @@ module TcUnify ( -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyTupleTy, + unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy, unifyKind, unifyKinds, unifyOpenTypeKind, -- Coercions @@ -51,7 +51,7 @@ import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newTyVarTy, newTyVarTys, newBoxityVar, newHoleTyVarTy, zonkTcType, zonkTcTyVars, zonkTcTyVar ) import TcSimplify ( tcSimplifyCheck ) -import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) +import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy ) import TcEnv ( TcTyThing(..), tcExtendGlobalTyVars, tcGetGlobalTyVars, tcLEnvElts ) import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) import PprType ( pprType ) @@ -734,6 +734,26 @@ unify_list_ty_help ty -- Revert to ordinary unification = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> unifyTauTy ty (mkListTy elt_ty) `thenTc_` returnTc elt_ty + +-- variant for parallel arrays +-- +unifyPArrTy :: TcType -- expected list type + -> TcM TcType -- list element type + +unifyPArrTy ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyPArrTy ty' + _ -> unify_parr_ty_help ty +unifyPArrTy ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnTc arg_ty + _ -> unify_parr_ty_help ty + +unify_parr_ty_help ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> + unifyTauTy ty (mkPArrTy elt_ty) `thenTc_` + returnTc elt_ty \end{code} \begin{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 0285731..39ae2ee 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -151,10 +151,18 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys) [ty] <- tys = brackets (ppr_ty tOP_PREC ty) + -- PARALLEL ARRAY CASE + | tycon `hasKey` parrTyConKey, + [ty] <- tys + = pabrackets (ppr_ty tOP_PREC ty) + -- GENERAL CASE | otherwise = ppr_tc_app ctxt_prec tycon tys + where + pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") + ppr_ty ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile index 9248da2..fe93463 100644 --- a/ghc/lib/std/Makefile +++ b/ghc/lib/std/Makefile @@ -58,6 +58,7 @@ PrelIO_HC_OPTS += -fno-ignore-asserts # Special options PrelStorable_HC_OPTS = -monly-3-regs PrelCError_HC_OPTS = +RTS -K4m -RTS +PrelPArr_HC_OPTS = -fparr #----------------------------------------------------------------------------- # Dependency generation diff --git a/ghc/lib/std/PrelPArr.hs b/ghc/lib/std/PrelPArr.hs new file mode 100644 index 0000000..ca9ea0e --- /dev/null +++ b/ghc/lib/std/PrelPArr.hs @@ -0,0 +1,644 @@ +-- $Id: PrelPArr.hs,v 1.2 2002/02/11 08:20:49 chak Exp $ +-- +-- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller +-- +-- Basic implementation of Parallel Arrays. +-- +--- DESCRIPTION --------------------------------------------------------------- +-- +-- This module has two functions: (1) It defines the interface to the +-- parallel array extension of the Prelude and (2) it provides a vanilla +-- implementation of parallel arrays that does not require to flatten the +-- array code. The implementation is not very optimised. +-- +--- DOCU ---------------------------------------------------------------------- +-- +-- Language: Haskell 98 plus unboxed values and parallel arrays +-- +-- The semantic difference between standard Haskell arrays (aka "lazy +-- arrays") and parallel arrays (aka "strict arrays") is that the evaluation +-- of two different elements of a lazy array is independent, whereas in a +-- strict array either non or all elements are evaluated. In other words, +-- when a parallel array is evaluated to WHNF, all its elements will be +-- evaluated to WHNF. The name parallel array indicates that all array +-- elements may, in general, be evaluated to WHNF in parallel without any +-- need to resort to speculative evaluation. This parallel evaluation +-- semantics is also beneficial in the sequential case, as it facilitates +-- loop-based array processing as known from classic array-based languages, +-- such as Fortran. +-- +-- The interface of this module is essentially a variant of the list +-- component of the Prelude, but also includes some functions (such as +-- permutations) that are not provided for lists. The following list +-- operations are not supported on parallel arrays, as they would require the +-- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'. +-- +-- The current implementation is quite simple and entirely based on boxed +-- arrays. One disadvantage of boxed arrays is that they require to +-- immediately initialise all newly allocated arrays with an error thunk to +-- keep the garbage collector happy, even if it is guaranteed that the array +-- is fully initialised with different values before passing over the +-- user-visible interface boundary. Currently, no effort is made to use +-- raw memory copy operations to speed things up. +-- +--- TODO ---------------------------------------------------------------------- +-- +-- * We probably want a standard library `PArray' in addition to the prelude +-- extension in the same way as the standard library `List' complements the +-- list functions from the prelude. +-- +-- * Currently, functions that emphasis the constructor-based definition of +-- lists (such as, head, last, tail, and init) are not supported. +-- +-- Is it worthwhile to support the string processing functions lines, +-- words, unlines, and unwords? (Currently, they are not implemented.) +-- +-- It can, however, be argued that it would be worthwhile to include them +-- for completeness' sake; maybe only in the standard library `PArray'. +-- +-- * Prescans are often more useful for array programming than scans. Shall +-- we include them into the Prelude or the library? +-- +-- * Due to the use of the iterator `loop', we could define some fusion rules +-- in this module. +-- +-- * We might want to add bounds checks that can be deactivated. +-- + +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelPArr ( + [::], -- abstract + + mapP, -- :: (a -> b) -> [:a:] -> [:b:] + (+:+), -- :: [:a:] -> [:a:] -> [:a:] + filterP, -- :: (a -> Bool) -> [:a:] -> [:a:] + concatP, -- :: [:[:a:]:] -> [:a:] + concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:] +-- head, last, tail, init, -- it's not wise to use them on arrays + nullP, -- :: [:a:] -> Bool + lengthP, -- :: [:a:] -> Int + (!:), -- :: [:a:] -> Int -> a + foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a + foldl1P, -- :: (a -> a -> a) -> [:a:] -> a + scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:] + scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] + foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b + foldr1P, -- :: (a -> a -> a) -> [:a:] -> a + scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:] + scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] +-- iterate, repeat, -- parallel arrays must be finite + replicateP, -- :: Int -> a -> [:a:] +-- cycle, -- parallel arrays must be finite + takeP, -- :: Int -> [:a:] -> [:a:] + dropP, -- :: Int -> [:a:] -> [:a:] + splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:]) + takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] + spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) + breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +-- lines, words, unlines, unwords, -- is string processing really needed + reverseP, -- :: [:a:] -> [:a:] + andP, -- :: [:Bool:] -> Bool + orP, -- :: [:Bool:] -> Bool + anyP, -- :: (a -> Bool) -> [:a:] -> Bool + allP, -- :: (a -> Bool) -> [:a:] -> Bool + elemP, -- :: (Eq a) => a -> [:a:] -> Bool + notElemP, -- :: (Eq a) => a -> [:a:] -> Bool + lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b + sumP, -- :: (Num a) => [:a:] -> a + productP, -- :: (Num a) => [:a:] -> a + maximumP, -- :: (Ord a) => [:a:] -> a + minimumP, -- :: (Ord a) => [:a:] -> a + zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :] + zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] + zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] + zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] + unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:]) + unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) + + -- overloaded functions + -- + enumFromToP, -- :: Enum a => a -> a -> [:a:] + enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:] + + -- the following functions are not available on lists + -- + toP, -- :: [a] -> [:a:] + fromP, -- :: [:a:] -> [a] + sliceP, -- :: Int -> Int -> [:e:] -> [:e:] + foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e + fold1P, -- :: (e -> e -> e) -> [:e:] -> e + permuteP, -- :: [:Int:] -> [:e:] -> [:e:] + bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] + bpermuteDftP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:] + crossP, -- :: [:a:] -> [:b:] -> [:(a, b):] + indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:] +) where + +import PrelBase +import PrelST (ST(..), STRep, runST) +import PrelList +import PrelShow +import PrelRead + +infixl 9 !: +infixr 5 +:+ +infix 4 `elemP`, `notElemP` + + +-- representation of parallel arrays +-- --------------------------------- + +-- this rather straight forward implementation maps parallel arrays to the +-- internal representation used for standard Haskell arrays in GHC's Prelude +-- (EXPORTED ABSTRACTLY) +-- +-- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! +-- +data [::] e = PArr Int# (Array# e) + + +-- exported operations on parallel arrays +-- -------------------------------------- + +-- operations corresponding to list operations +-- + +mapP :: (a -> b) -> [:a:] -> [:b:] +mapP f = fst . loop (mapEFL f) noAL + +(+:+) :: [:a:] -> [:a:] -> [:a:] +a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1)) + -- we can't use the [:x..y:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromToP' is defined in the same module + where + len1 = lengthP a1 + len2 = lengthP a2 + -- + sel i | i < len1 = a1!:i + | otherwise = a2!:(i - len1) + +filterP :: (a -> Bool) -> [:a:] -> [:a:] +filterP p = fst . loop (filterEFL p) noAL + +concatP :: [:[:a:]:] -> [:a:] +concatP xss = foldlP (+:+) [::] xss + +concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:] +concatMapP f = concatP . mapP f + +-- head, last, tail, init, -- it's not wise to use them on arrays + +nullP :: [:a:] -> Bool +nullP [::] = True +nullP _ = False + +lengthP :: [:a:] -> Int +lengthP (PArr n# _) = I# n# + +(!:) :: [:a:] -> Int -> a +(!:) = indexPArr + +foldlP :: (a -> b -> a) -> a -> [:b:] -> a +foldlP f z = snd . loop (foldEFL (flip f)) z + +foldl1P :: (a -> a -> a) -> [:a:] -> a +foldl1P f [::] = error "Prelude.foldl1P: empty array" +foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a + +scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:] +scanlP f z = fst . loop (scanEFL (flip f)) z + +scanl1P :: (a -> a -> a) -> [:a:] -> [:a:] +acanl1P f [::] = error "Prelude.scanl1P: empty array" +scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a + +foldrP :: (a -> b -> b) -> b -> [:a:] -> b +foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME + +foldr1P :: (a -> a -> a) -> [:a:] -> a +foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME + +scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:] +scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME + +scanr1P :: (a -> a -> a) -> [:a:] -> [:a:] +scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME + +-- iterate, repeat -- parallel arrays must be finite + +replicateP :: Int -> a -> [:a:] +{-# INLINE replicateP #-} +replicateP n e = runST (do + marr# <- newArray n e + mkPArr n marr#) + +-- cycle -- parallel arrays must be finite + +takeP :: Int -> [:a:] -> [:a:] +takeP n = sliceP 0 (n - 1) + +dropP :: Int -> [:a:] -> [:a:] +dropP n a = sliceP (n - 1) (lengthP a - 1) a + +splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) +splitAtP n xs = (takeP n xs, dropP n xs) + +takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] +takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME + +dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] +dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME + +spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +spanP = error "Prelude.spanP: not implemented yet" -- FIXME + +breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) +breakP p = spanP (not . p) + +-- lines, words, unlines, unwords, -- is string processing really needed + +reverseP :: [:a:] -> [:a:] +reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a + -- we can't use the [:x, y..z:] form here for tedious + -- reasons to do with the typechecker and the fact that + -- `enumFromThenToP' is defined in the same module + where + len = lengthP a + +andP :: [:Bool:] -> Bool +andP = foldP (&&) True + +orP :: [:Bool:] -> Bool +orP = foldP (||) True + +anyP :: (a -> Bool) -> [:a:] -> Bool +anyP p = orP . mapP p + +allP :: (a -> Bool) -> [:a:] -> Bool +allP p = andP . mapP p + +elemP :: (Eq a) => a -> [:a:] -> Bool +elemP x = anyP (== x) + +notElemP :: (Eq a) => a -> [:a:] -> Bool +notElemP x = allP (/= x) + +lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b +lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME + +sumP :: (Num a) => [:a:] -> a +sumP = foldP (+) 0 + +productP :: (Num a) => [:a:] -> a +productP = foldP (*) 0 + +maximumP :: (Ord a) => [:a:] -> a +maximumP [::] = error "Prelude.maximumP: empty parallel array" +maximumP xs = fold1P max xs + +minimumP :: (Ord a) => [:a:] -> a +minimumP [::] = error "Prelude.minimumP: empty parallel array" +minimumP xs = fold1P min xs + +zipP :: [:a:] -> [:b:] -> [:(a, b):] +zipP = zipWithP (,) + +zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] +zip3P = zipWith3P (,,) + +zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] +zipWithP f a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 `min` len2 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i), i + 1) + +zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] +zipWith3P f a1 a2 a3 = let + len1 = lengthP a1 + len2 = lengthP a2 + len3 = lengthP a3 + len = len1 `min` len2 `min` len3 + in + fst $ loopFromTo 0 (len - 1) combine 0 a1 + where + combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) + +unzipP :: [:(a, b):] -> ([:a:], [:b:]) +unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) +-- FIXME: these two functions should be optimised using a tupled custom loop +unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) +unzip3P a = (fst $ loop (mapEFL fst3) noAL a, + fst $ loop (mapEFL snd3) noAL a, + fst $ loop (mapEFL trd3) noAL a) + where + fst3 (a, _, _) = a + snd3 (_, b, _) = b + trd3 (_, _, c) = c + +-- instances +-- + +instance Eq a => Eq [:a:] where + a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) + | otherwise = False + +instance Ord a => Ord [:a:] where + compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of + EQ | lengthP a1 == lengthP a2 -> EQ + | lengthP a1 < lengthP a2 -> LT + | otherwise -> GT + where + combineOrdering EQ EQ = EQ + combineOrdering EQ other = other + combineOrdering other _ = other + +instance Functor [::] where + fmap = mapP + +instance Monad [::] where + m >>= k = foldrP ((+:+) . k ) [::] m + m >> k = foldrP ((+:+) . const k) [::] m + return x = [:x:] + fail _ = [::] + +instance Show a => Show [:a:] where + showsPrec _ = showPArr . fromP + where + showPArr [] s = "[::]" ++ s + showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) + + showPArr' [] s = ":]" ++ s + showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) + +instance Read a => Read [:a:] where + readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] + where + readPArr = readParen False (\r -> do + ("[:",s) <- lex r + readPArr1 s) + readPArr1 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) + + readPArr2 s = + (do { (":]", t) <- lex s; return ([], t) }) ++ + (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; + return (x:xs, v) }) + +-- overloaded functions +-- + +-- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of +-- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, +-- for the moment, we hope that the compiler is sufficiently clever to +-- properly fuse the following definition. + +enumFromToP :: Enum a => a -> a -> [:a:] +enumFromToP x y = mapP toEnum (eftInt (fromEnum x) (fromEnum y)) + where + eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1 + +enumFromThenToP :: Enum a => a -> a -> a -> [:a:] +enumFromThenToP x y z = + mapP toEnum (efttInt (fromEnum x) (fromEnum y) (fromEnum z)) + where + efttInt x y z = scanlP (+) x $ + replicateP ((z - x + 1) `div` delta - 1) delta + where + delta = y - x + +-- the following functions are not available on lists +-- + +-- create an array from a list (EXPORTED) +-- +toP :: [a] -> [:a:] +toP l = fst $ loop store l (replicateP (length l) ()) + where + store _ (x:xs) = (Just x, xs) + +-- convert an array to a list (EXPORTED) +-- +fromP :: [:a:] -> [a] +fromP a = [a!:i | i <- [0..lengthP a - 1]] + +-- cut a subarray out of an array (EXPORTED) +-- +sliceP :: Int -> Int -> [:e:] -> [:e:] +sliceP from to a = + fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a + +-- parallel folding (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +foldP :: (e -> e -> e) -> e -> [:e:] -> e +foldP = foldlP + +-- parallel folding without explicit neutral (EXPORTED) +-- +-- * the first argument must be associative; otherwise, the result is undefined +-- +fold1P :: (e -> e -> e) -> [:e:] -> e +fold1P = foldl1P + +-- permute an array according to the permutation vector in the first argument +-- (EXPORTED) +-- +permuteP :: [:Int:] -> [:e:] -> [:e:] +permuteP is es = fst $ loop (mapEFL (es!:)) noAL is + +-- permute an array according to the back-permutation vector in the first +-- argument (EXPORTED) +-- +-- * the permutation vector must represent a surjective function; otherwise, +-- the result is undefined +-- +bpermuteP :: [:Int:] -> [:e:] -> [:e:] +bpermuteP is es = error "Prelude.bpermuteP: not implemented yet" -- FIXME + +-- permute an array according to the back-permutation vector in the first +-- argument, which need not be surjective (EXPORTED) +-- +-- * any elements in the result that are not covered by the back-permutation +-- vector assume the value of the corresponding position of the third +-- argument +-- +bpermuteDftP :: [:Int:] -> [:e:] -> [:e:] -> [:e:] +bpermuteDftP is es = error "Prelude.bpermuteDftP: not implemented yet"-- FIXME + +-- computes the cross combination of two arrays (EXPORTED) +-- +crossP :: [:a:] -> [:b:] -> [:(a, b):] +crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len () + where + len1 = lengthP a1 + len2 = lengthP a2 + len = len1 * len2 + -- + combine _ (i, j) = (Just $ (a1!:i, a2!:j), next) + where + next | (i + 1) == len1 = (0 , j + 1) + | otherwise = (i + 1, j) + +{- An alternative implementation + * The one above is certainly better for flattened code, but here where we + are handling boxed arrays, the trade off is less clear. However, I + think, the above one is still better. + +crossP a1 a2 = let + len1 = lengthP a1 + len2 = lengthP a2 + x1 = concatP $ mapP (replicateP len2) a1 + x2 = concatP $ replicateP len1 a2 + in + zipP x1 x2 + -} + +-- computes an index array for all elements of the second argument for which +-- the predicate yields `True' (EXPORTED) +-- +indexOfP :: (a -> Bool) -> [:a:] -> [:Int:] +indexOfP p a = fst $ loop calcIdx 0 a + where + calcIdx e idx | p e = (Just idx, idx + 1) + | otherwise = (Nothing , idx ) + + +-- auxiliary functions +-- ------------------- + +-- internally used mutable boxed arrays +-- +data MPArr s e = MPArr Int# (MutableArray# s e) + +-- allocate a new mutable array that is pre-initialised with a given value +-- +newArray :: Int -> e -> ST s (MPArr s e) +{-# INLINE newArray #-} +newArray (I# n#) e = ST $ \s1# -> + case newArray# n# e s1# of { (# s2#, marr# #) -> + (# s2#, MPArr n# marr# #)} + +-- convert a mutable array into the external parallel array representation +-- +mkPArr :: Int -> MPArr s e -> ST s [:e:] +{-# INLINE mkPArr #-} +mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# -> + case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, PArr n# arr# #) } + +-- general array iterator +-- +-- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty & +-- Keller, ICFP 2001 +-- +loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element + -> acc -- initial acc value + -> [:e:] -- input array + -> ([:e':], acc) +{-# INLINE loop #-} +loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr + +-- general array iterator with bounds +-- +loopFromTo :: Int -- from index + -> Int -- to index + -> (e -> acc -> (Maybe e', acc)) + -> acc + -> [:e:] + -> ([:e':], acc) +{-# INLINE loopFromTo #-} +loopFromTo from to mf start arr = runST (do + marr <- newArray (to - from + 1) noElem + (n', acc) <- trans from to marr arr mf start + arr <- mkPArr n' marr + return (arr, acc)) + where + noElem = error "PrelPArr.loopFromTo: I do not exist!" + -- unlike standard Haskell arrays, this value represents an + -- internal error + +-- actually loop body of `loop' +-- +-- * for this to be really efficient, it has to be translated with the +-- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03 +-- this requires an optimisation level of at least -O2 +-- +trans :: Int -- index of first elem to process + -> Int -- index of last elem to process + -> MPArr s e' -- destination array + -> [:e:] -- source array + -> (e -> acc -> (Maybe e', acc)) -- mutator + -> acc -- initial accumulator + -> ST s (Int, acc) -- final destination length/final acc +{-# INLINE trans #-} +trans from to marr arr mf start = trans' from 0 start + where + trans' arrOff marrOff acc + | arrOff > to = return (marrOff, acc) + | otherwise = do + let (oe', acc') = mf (arr `indexPArr` arrOff) acc + marrOff' <- case oe' of + Nothing -> return marrOff + Just e' -> do + writeMPArr marr marrOff e' + return $ marrOff + 1 + trans' (arrOff + 1) marrOff' acc' + + +-- common patterns for using `loop' +-- + +-- initial value for the accumulator when the accumulator is not needed +-- +noAL :: () +noAL = () + +-- `loop' mutator maps a function over array elements +-- +mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ())) +{-# INLINE mapEFL #-} +mapEFL f = \e a -> (Just $ f e, ()) + +-- `loop' mutator that filter elements according to a predicate +-- +filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ())) +{-# INLINE filterEFL #-} +filterEFL p = \e a -> if p e then (Just e, ()) else (Nothing, ()) + +-- `loop' mutator for array folding +-- +foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc)) +{-# INLINE foldEFL #-} +foldEFL f = \e a -> (Nothing, f e a) + +-- `loop' mutator for array scanning +-- +scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc)) +{-# INLINE scanEFL #-} +scanEFL f = \e a -> (Just a, f e a) + +-- elementary array operations +-- + +-- unlifted array indexing +-- +indexPArr :: [:e:] -> Int -> e +{-# INLINE indexPArr #-} +indexPArr (PArr _ arr#) (I# i#) = + case indexArray# arr# i# of (# e #) -> e + +-- encapsulate writing into a mutable array into the `ST' monad +-- +writeMPArr :: MPArr s e -> Int -> e -> ST s () +{-# INLINE writeMPArr #-} +writeMPArr (MPArr _ marr#) (I# i#) e = ST $ \s# -> + case writeArray# marr# i# e s# of s'# -> (# s'#, () #) -- 1.7.10.4