Commit 10fcd78c authored by chak's avatar chak

[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.
parent 723ab336
# -----------------------------------------------------------------------------
# $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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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!
......
%
% (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}
......@@ -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}
......
......@@ -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
......
......@@ -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)