-
Notifications
You must be signed in to change notification settings - Fork 1
/
PatternBind.lhs
238 lines (211 loc) · 10.2 KB
/
PatternBind.lhs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
% -*- LaTeX -*-
% $Id: PatternBind.lhs 3206 2016-06-07 07:17:22Z wlux $
%
% Copyright (c) 2003-2016, Wolfgang Lux
% See LICENSE for the full license.
%
\nwfilename{PatternBind.lhs}
\section{Pattern Binding Updates}\label{sec:pattern-bindings}
The standard implementation of pattern bindings for local declarations
transforms each pattern declaration $t$~\texttt{=}~$e$, where $t$ is
not a variable pattern, into a list of declarations
$v_0$~\texttt{=}~$e$\texttt{;} $v_1$~\texttt{=}~$f_1$~$v_0$\texttt{;}
\dots{} \texttt{;} $v_n$~\texttt{=}~$f_n$~$v_0$ where $v_0$ is a fresh
variable, $v_1,\dots,v_n$ are the variables occurring in $t$ and the
auxiliary functions $f_i$ are defined by $f_i$~$t$~\texttt{=}~$v_i$
(see also appendix D.8 of the Curry report~\cite{Hanus:Report}).
Unfortunately, this transformation introduces a well-known space
leak~\cite{Wadler87:Leaks,Sparud93:Leaks}, since the matched
expression cannot be garbage collected before all of the matched
variables have been evaluated. Consider the following function:
\begin{verbatim}
f x | all (' ' ==) cs = c where (c:cs) = x
\end{verbatim}
One might expect the call \verb|f (replicate 10000 ' ')| to execute in
constant space because (the tail of) the long list of blanks is
consumed and discarded immediately by \texttt{all}. However, the
application of the selector function that extracts the head of the
list is not evaluated until after the guard succeeds and thus prevents
the whole list from being garbage collected. In order to avoid this
space leak we use the approach from~\cite{Sparud93:Leaks} and update
all pattern variables when one of the components is
evaluated.\footnote{We do not attempt to fix the space leak with the
garbage collector~\cite{Wadler87:Leaks} because the updates may have
to be undone when executed in non-deterministic code. Detecting when
recording an update is necessary, and in particular where to record
it, is quite difficult for the garbage collector due to the presence
of encapsulated search in Curry.} Our transformation, which is
explained below, uses two new primitives \texttt{pbUpdate} and
\texttt{pbReturn} and foreign function declarations for them are added
to the program when necessary. In order to detect when adding these
declarations is necessary, we simply check whether any fresh variables
were introduced in the code by the transformation.
\begin{verbatim}
> module PatternBind(pbTrans) where
> import Base
> import Combined
> import Curry
> import CurryUtils
> import Monad
> import Position
> import PredefIdent
> import PredefTypes
> import Types
> import TypeTrans
> import Typing
> import ValueInfo
> type PatternBindState a = StateT Int Id a
> pbTrans :: ValueEnv -> Module Type -> (ValueEnv,Module Type)
> pbTrans tyEnv m = runSt (pbtModule tyEnv m) 1
> pbtModule :: ValueEnv -> Module Type
> -> PatternBindState (ValueEnv,Module Type)
> pbtModule tyEnv (Module m es is ds) =
> do
> n <- fetchSt
> ds' <- mapM (pbt m) ds
> n' <- fetchSt
> let ap = if n == n' then const id else ($)
> return (ap bindPrims tyEnv,Module m es is (ap (prims ++) ds'))
> where noPos = internalError "pbtModule: no position"
> Variable tyUpd pbUpd = pbUpdate m (TypeVariable 0)
> Variable tyRet pbRet = pbReturn m (TypeVariable 0)
> bindPrims = bindForeign pbUpd tyUpd . bindForeign pbRet tyRet
> prims =
> [BlockDecl (foreignDecl noPos "pbUpdate" pbUpd tyUpd),
> BlockDecl (foreignDecl noPos "pbReturn" pbRet tyRet)]
> class SyntaxTree a where
> pbt :: ModuleIdent -> a Type -> PatternBindState (a Type)
> instance SyntaxTree TopDecl where
> pbt _ (DataDecl p tc tvs cs) = return (DataDecl p tc tvs cs)
> pbt _ (NewtypeDecl p tc tvs nc) = return (NewtypeDecl p tc tvs nc)
> pbt _ (TypeDecl p tc tvs ty) = return (TypeDecl p tc tvs ty)
> pbt m (BlockDecl d) = liftM BlockDecl (pbt m d)
> instance SyntaxTree Decl where
> pbt m (FunctionDecl p ty f eqs) =
> liftM (FunctionDecl p ty f) (mapM (pbt m) eqs)
> pbt _ (ForeignDecl p fi ty f ty') = return (ForeignDecl p fi ty f ty')
> pbt m (PatternDecl p t rhs) = liftM (PatternDecl p t) (pbt m rhs)
> pbt _ (FreeDecl p vs) = return (FreeDecl p vs)
> instance SyntaxTree Equation where
> pbt m (Equation p lhs rhs) = liftM (Equation p lhs) (pbt m rhs)
> instance SyntaxTree Rhs where
> pbt m (SimpleRhs p e _) = liftM (flip (SimpleRhs p) []) (pbt m e)
> instance SyntaxTree Expression where
> pbt _ (Literal ty l) = return (Literal ty l)
> pbt _ (Variable ty v) = return (Variable ty v)
> pbt _ (Constructor ty c) = return (Constructor ty c)
> pbt m (Tuple es) = liftM Tuple (mapM (pbt m) es)
> pbt m (Apply e1 e2) = liftM2 Apply (pbt m e1) (pbt m e2)
> pbt m (Lambda p ts e) = liftM (Lambda p ts) (pbt m e)
> pbt m (Let ds e) = liftM2 (Let . concat) (mapM (pbtDecl m) ds) (pbt m e)
> where fvs = qfv m ds ++ qfv m e
> pbtDecl m d = pbt m d >>= expandPatternBindings m fvs
> pbt m (Case e as) = liftM2 Case (pbt m e) (mapM (pbt m) as)
> pbt m (Fcase e as) = liftM2 Fcase (pbt m e) (mapM (pbt m) as)
> instance SyntaxTree Alt where
> pbt m (Alt p t rhs) = liftM (Alt p t) (pbt m rhs)
\end{verbatim}
In order to update all pattern variables when one of the selector
functions for a pattern binding has been evaluated, we introduce an
auxiliary constraint function that matches the pattern with the right
hand side expression of the declaration and then updates \emph{all}
pattern variables. The selector function for each pattern variable
first evaluates the shared constraint and then returns the respective
pattern component. Recall that case matching transforms each pattern
declaration of the form $t$~\texttt{=}~$e$, where $t$ is not a
variable pattern, into an equation
\begin{center}
\begin{tabular}{l}
\texttt{$(v_1,\dots,v_n)$ = fcase $e$ of \lb{} $t'_1$ -> $\dots$
fcase $u_k$ of \lb{} $t'_k$ -> $(v_1,\dots,v_n)$ \rb{}$\dots$\rb{}},
\end{tabular}
\end{center}
where $v_1,\dots,v_n$ are the free variables of $t$, the patterns
$t'_1,\dots,t'_k$ are flat patterns using fresh variables, and
$u_2,\dots,u_k$ are variables occurring in these patterns such that
the right hand side of the equation matches the same pattern as $t$.
Also recall that the simplifier reduces the tuples $(v_1,\dots,v_n)$
to those variables which are actually used in the scope of the
declaration. Each such equation is now transformed by
\texttt{expandPatternBindings} into a list of equations
\begin{center}\tt
\begin{tabular}{rcl}
$v_0$ & = & fcase $e$ of \lb{} $t'_1$ -> $\dots$
fcase $u_k$ of \lb{} $t'_k$ -> $e'$ \rb{}$\dots$\rb{} \\
& & \textrm{where $e' =$
\texttt{pbUpdate $v_1$ $v'_1$ \&> $\dots$ \&>
pbUpdate $v_n$ $v'_n$}} \\
$v_1$ & = & pbReturn $v_0$ $v_1$ \\
\multicolumn{3}{l}{\dots} \\
$v_n$ & = & pbReturn $v_0$ $v_n$ \\
\end{tabular}
\end{center}
where $v_0$ is a fresh variable and $v'_1,\dots,v'_n$ are variables
from $t'_1,\dots,t'_k$ that match the same components as
$v_1,\dots,v_n$, respectively, in $t$. Each application
\texttt{pbUpdate $v_i$ $v'_i$} updates the lazy application node bound
to $v_i$ with the pattern component bound to $v'_i$. An application
\texttt{pbReturn $v_0$ $v_i$} is evaluated similar to \texttt{$v_0$
\&> $v_i$}, but \texttt{pbReturn} is prepared to handle the fact
that the lazy application bound to $v_i$ is already updated by the
constraint $v_0$.
\begin{verbatim}
> expandPatternBindings :: ModuleIdent -> [Ident] -> Decl Type
> -> PatternBindState [Decl Type]
> expandPatternBindings m fvs (PatternDecl p t rhs) =
> case (t,rhs) of
> (VariablePattern _ _,_) -> return [PatternDecl p t rhs]
> (TuplePattern ts,SimpleRhs _ e _) ->
> do
> v0 <- freshVar "_#pbt" boolType
> return (updateDecl m p v0 vs e :
> map (selectorDecl m p (uncurry mkVar v0)) vs)
> where vs = [(ty,v) | VariablePattern ty v <- ts]
> expandPatternBindings _ _ d = return [d]
> updateDecl :: ModuleIdent -> Position -> (Type,Ident) -> [(Type,Ident)]
> -> Expression Type -> Decl Type
> updateDecl m p v0 vs e = uncurry (varDecl p) v0 (fixBody vs e)
> where fixBody vs (Tuple es) = foldr1 (cond p) (zipWith (update m) vs es)
> fixBody vs (Let ds e) = Let ds (fixBody vs e)
> fixBody vs (Case e [Alt p t rhs]) = Case e [Alt p t (fixRhs vs rhs)]
> fixBody vs (Fcase e [Alt p t rhs]) = Fcase e [Alt p t (fixRhs vs rhs)]
> fixRhs vs (SimpleRhs p e _) = SimpleRhs p (fixBody vs e) []
> cond :: Position -> Expression Type -> Expression Type -> Expression Type
> cond p c e = Case c [caseAlt p truePattern e]
> where truePattern = ConstructorPattern boolType qTrueId []
> update :: ModuleIdent -> (Type,Ident) -> Expression Type -> Expression Type
> update m v = Apply (Apply (pbUpdate m (fst v)) (uncurry mkVar v))
> selectorDecl :: ModuleIdent -> Position -> Expression Type -> (Type,Ident)
> -> Decl Type
> selectorDecl m p e v = uncurry (varDecl p) v (ret m e v)
> ret :: ModuleIdent -> Expression Type -> (Type,Ident) -> Expression Type
> ret m e v = apply (pbReturn m (fst v)) [e,uncurry mkVar v]
\end{verbatim}
Pattern binding primitives.
\begin{verbatim}
> pbUpdate, pbReturn :: ModuleIdent -> Type -> Expression Type
> pbUpdate m ty = pbFun m [ty,ty] boolType "_#update"
> pbReturn m ty = pbFun m [boolType,ty] ty "_#return"
> pbFun :: ModuleIdent -> [Type] -> Type -> String -> Expression Type
> pbFun m tys ty f =
> Variable (foldr TypeArrow ty tys) (qualifyWith m (mkIdent f))
\end{verbatim}
Generation of fresh names.
\begin{verbatim}
> freshVar :: String -> Type -> PatternBindState (Type,Ident)
> freshVar prefix ty =
> do
> v <- liftM mkName (updateSt (1 +))
> return (ty,v)
> where mkName n = renameIdent (mkIdent (prefix ++ show n)) n
\end{verbatim}
Auxiliary functions.
\begin{verbatim}
> foreignDecl :: Position -> String -> QualIdent -> Type -> Decl Type
> foreignDecl p ie f ty =
> ForeignDecl p (CallConvPrimitive,Just Safe,Just ie) ty (unqualify f)
> (fromType nameSupply ty)
> bindForeign :: QualIdent -> Type -> ValueEnv -> ValueEnv
> bindForeign f ty = bindFun m f' (arrowArity ty) (polyType ty)
> where (Just m,f') = splitQualIdent f
\end{verbatim}