1 (* Semantic Analysis
*)
3 signature SEMANTIC_ANALYSIS
=
5 val removeNestedDefine
: Expr
-> Expr
;
6 val boxSet
: Expr
-> Expr
;
7 val annotateTC
: Expr
-> Expr
;
8 val lexicalAddressing
: Expr
-> Expr
;
9 val semanticAnalysis
: Expr
-> Expr
;
12 (* ******************************************************* Semantic Analysis
*)
14 (* union any number
of lists
*)
15 fun union
[set
, []] = set
16 | union
[set
, (x
:: rest
)] =
17 if not (List.exists (fn em
=> em
=x
) set
) then
18 union
[(x
:: set
), rest
]
21 |
union (A
:: (B
:: rest
)) = union
[A
, union (B
:: rest
)]
25 (* intersect any number
of lists
*)
26 fun intersect
[set
,[]] = []
27 | intersect
[set
, (x
:: rest
)] =
28 if List.exists (fn em
=> em
=x
) set
then
29 intersect
[set
,rest
] @
[x
]
32 |
intersect (A
:: (B
:: rest
)) = intersect
[A
, intersect (B
:: rest
)]
36 (* (subtract A B
) <==> A
-B
*)
37 fun subtract set
[] = set
38 | subtract
set (x
:: rest
) =
39 subtract (List.filter (fn em
=> em
<>x
) set
) rest
;
41 (* (isMember e
) S
= true iff e is
in S
*)
42 fun isMember e
= List.exists (fn e
' => e
'=e
);
44 exception ErrorEmptyBody
;
45 exception ErrorNotAVar
;
46 exception ErrorInvalidDefineContext
;
48 structure SemanticAnalysis
: SEMANTIC_ANALYSIS
=
51 (* Keeps only first
-level Seq objects
, dissolves the inner ones
*)
52 fun flattenSeq(Seq
[e
]) = e
53 |
flattenSeq(Seq(cnt
)) = Seq(dissolveSeq cnt
)
54 |
flattenSeq(If(p
,c
,a
)) = If(flattenSeq(p
),flattenSeq(c
),flattenSeq(a
))
55 |
flattenSeq(Abs(p
,b
)) = Abs(p
,flattenSeq(b
))
56 |
flattenSeq(AbsOpt(p
,opt
,b
)) = AbsOpt(p
,opt
,flattenSeq(b
))
57 |
flattenSeq(AbsVar(opt
,b
)) = AbsVar(opt
,flattenSeq(b
))
58 |
flattenSeq(App(proc
,params
)) = App(flattenSeq(proc
), map flattenSeq params
)
59 |
flattenSeq(AppTP(proc
,params
)) = AppTP(flattenSeq(proc
), map flattenSeq params
)
60 |
flattenSeq(Or preds
) = Or( map flattenSeq preds
)
61 |
flattenSeq(Set(v
,e
)) = Set(v
,flattenSeq(e
))
62 |
flattenSeq(Def(v
,e
)) = Def(v
,flattenSeq(e
))
64 (* Recursively replaces any
Seq(x
) with x
*)
65 and dissolveSeq(Seq(cnt
) :: rest
) = dissolveSeq(cnt
) @
dissolveSeq(rest
)
66 |
dissolveSeq(ex
:: rest
) = flattenSeq(ex
) :: dissolveSeq(rest
)
67 |
dissolveSeq([]) = [];
69 (* Keeps only top
-level Define objects
, and
70 expands the inner ones to letrec
.
71 Inner Define objects must be first
in the sequence
of statements
.
73 top
-level Define objects
: Define objects that affect the global enviroment
75 fun removeNestedDefine
'(e
as Abs(_
,Def(_
,_
))) = raise ErrorEmptyBody
76 | removeNestedDefine
'(e
as AbsOpt(_
,_
,Def(_
,_
))) = raise ErrorEmptyBody
77 | removeNestedDefine
'(e
as AbsVar(_
,Def(_
,_
))) = raise ErrorEmptyBody
78 | removeNestedDefine
'(Abs(p
,Seq (cnt
as (Def(_
,_
) :: _
)))) = Abs(p
,expandDefines(cnt
,[],[]))
79 | removeNestedDefine
'(AbsOpt(p
,opt
,Seq (cnt
as (Def(_
,_
) :: _
)))) = AbsOpt(p
,opt
,expandDefines(cnt
,[],[]))
80 | removeNestedDefine
'(AbsVar(opt
,Seq (cnt
as (Def(_
,_
) :: _
)))) = AbsVar(opt
,expandDefines(cnt
,[],[]))
81 | removeNestedDefine
'(Abs(p
,b
)) = Abs(p
,removeNestedDefine
'(b
))
82 | removeNestedDefine
'(AbsOpt(p
,opt
,b
)) = AbsOpt(p
,opt
,removeNestedDefine
'(b
))
83 | removeNestedDefine
'(AbsVar(opt
,b
)) = AbsVar(opt
,removeNestedDefine
'(b
))
84 | removeNestedDefine
'(If(p
,c
,a
)) = If(removeNestedDefine
'(p
),removeNestedDefine
'(c
),removeNestedDefine
'(a
))
85 | removeNestedDefine
'(App(proc
,params
)) = App(removeNestedDefine
'(proc
),map removeNestedDefine
' params
)
86 | removeNestedDefine
'(AppTP(proc
,params
)) = AppTP(removeNestedDefine
'(proc
),map removeNestedDefine
' params
)
87 | removeNestedDefine
'(Seq(cnt
)) = Seq(map removeNestedDefine
' cnt
)
88 | removeNestedDefine
'(Or preds
) = Or(map removeNestedDefine
' preds
)
89 | removeNestedDefine
'(Set(v
,e
)) = Set(v
,removeNestedDefine
'(e
))
90 | removeNestedDefine
'(Def(v
,e
)) = Def(v
,removeNestedDefine
'(e
))
91 | removeNestedDefine
'(x
) = x
92 and expandDefines([],_
,_
) = raise ErrorEmptyBody
93 |
expandDefines(Def(v
,e
) :: rest
,vars
,vals
) = expandDefines(rest
,v
:: vars
, e
:: vals
)
94 |
expandDefines(body
,vars
,vals
) =
95 makeLetRec(extractVarNames(List.rev(vars
)),
97 map removeNestedDefine
' body
)
98 and makeLetRec(vars
,vals
,body
) =
99 App(Abs(vars
,Seq(makeSetExprs(vars
,vals
) @ body
)),map makeFalse vals
)
100 and makeSetExprs([],_
) = []
101 |
makeSetExprs(_
,[]) = []
102 |
makeSetExprs(v
:: restVars
, e
:: restVals
) = Set(Var(v
),removeNestedDefine
'(e
)) :: makeSetExprs(restVars
,restVals
)
103 and makeFalse(_
) = Const(Bool false)
104 and extractVarNames([]) = []
105 |
extractVarNames(Var(name
) :: rest
) = name
:: extractVarNames(rest
)
106 |
extractVarNames(_
) = raise ErrorNotAVar
107 and removeNestedDefine x
= removeNestedDefine
' (flattenSeq x
);
109 (* Raises an error
if there is a Define object
with an invalid
context (such
as
110 a Define inside an Abs
) *)
111 fun checkDefineContexts(If(p
,c
,a
)) = If(checkDefineContexts(p
),checkDefineContexts(c
),checkDefineContexts(a
))
112 |
checkDefineContexts(Abs(p
,b
)) = Abs(p
,raiseErrorOnDefine(b
))
113 |
checkDefineContexts(AbsOpt(p
,opt
,b
)) = AbsOpt(p
,opt
,raiseErrorOnDefine(b
))
114 |
checkDefineContexts(AbsVar(opt
,b
)) = AbsVar(opt
,raiseErrorOnDefine(b
))
115 |
checkDefineContexts(App(proc
,params
)) = App(checkDefineContexts(proc
),map checkDefineContexts params
)
116 |
checkDefineContexts(AppTP(proc
,params
)) = AppTP(checkDefineContexts(proc
),map checkDefineContexts params
)
117 |
checkDefineContexts(Seq cnt
) = Seq( map checkDefineContexts cnt
)
118 |
checkDefineContexts(Or preds
) = Or( map checkDefineContexts preds
)
119 |
checkDefineContexts(Set(v
,e
)) = Set(v
,checkDefineContexts(e
))
120 |
checkDefineContexts(Def(v
,e
)) = Def(v
,checkDefineContexts(e
))
121 |
checkDefineContexts(x
) = x
122 and raiseErrorOnDefine(Def(_
,_
)) = raise ErrorInvalidDefineContext
123 |
raiseErrorOnDefine(If(p
,c
,a
)) = If(raiseErrorOnDefine(p
),raiseErrorOnDefine(c
),raiseErrorOnDefine(a
))
124 |
raiseErrorOnDefine(Abs(p
,b
)) = Abs(p
,raiseErrorOnDefine(b
))
125 |
raiseErrorOnDefine(AbsOpt(p
,opt
,b
)) = AbsOpt(p
,opt
,raiseErrorOnDefine(b
))
126 |
raiseErrorOnDefine(AbsVar(opt
,b
)) = AbsVar(opt
,raiseErrorOnDefine(b
))
127 |
raiseErrorOnDefine(App(proc
,params
)) = App(raiseErrorOnDefine(proc
),map raiseErrorOnDefine params
)
128 |
raiseErrorOnDefine(AppTP(proc
,params
)) = AppTP(raiseErrorOnDefine(proc
),map raiseErrorOnDefine params
)
129 |
raiseErrorOnDefine(Seq cnt
) = Seq( map raiseErrorOnDefine cnt
)
130 |
raiseErrorOnDefine(Or preds
) = Or( map raiseErrorOnDefine preds
)
131 |
raiseErrorOnDefine(Set(v
,e
)) = Set(v
,raiseErrorOnDefine(e
))
132 |
raiseErrorOnDefine(x
) = x
;
134 (* Annotates tail applications
.
135 Takes an Expr
as an argument
and returns an Expr
, in which all
136 App
-expressions that are
in tail position have been replaced
with
137 corresponding AppTP
-expressions
.
139 datatype Context
= Head | Tail
;
140 fun annotateInContext
context (If(test
,dit
,dif
)) =
141 If((annotateInContext Head test
),(annotateInContext context dit
),(annotateInContext context dif
))
142 | annotateInContext
context (Seq
[]) = Seq
[]
143 | annotateInContext
context (Seq cnt
) =
145 val last
:: rest
= List.rev cnt
146 val annotatedLast
= annotateInContext context last
147 val annotatedRest
= map (annotateInContext Head
) rest
149 Seq(List.rev( annotatedLast
:: annotatedRest
))
151 | annotateInContext
context (Or
[]) = Or
[]
152 | annotateInContext
context (Or preds
) =
154 val last
:: rest
= List.rev preds
155 val annotatedLast
= annotateInContext context last
156 val annotatedRest
= map (annotateInContext Head
) rest
158 Or(List.rev( annotatedLast
:: annotatedRest
))
160 | annotateInContext
_ (Set(n
,v
)) = Set( (annotateInContext Head n
), (annotateInContext Head v
) )
161 | annotateInContext
_ (Def(n
,v
)) = Def( (annotateInContext Head n
), (annotateInContext Head v
) )
162 | annotateInContext
Head (App(proc
,args
)) = App( (annotateInContext Head proc
), map (annotateInContext Head
) args
)
163 | annotateInContext
Tail (App(proc
,args
)) = AppTP( (annotateInContext Head proc
), map (annotateInContext Head
) args
)
164 | annotateInContext
_ (Abs(p
,b
)) = Abs(p
, annotateInContext Tail b
)
165 | annotateInContext
_ (AbsOpt(p
,opt
,b
)) = AbsOpt(p
,opt
,annotateInContext Tail b
)
166 | annotateInContext
_ (AbsVar(opt
,b
)) = AbsVar(opt
, annotateInContext Tail b
)
167 | annotateInContext _ x
= x
168 and annotateTC(x
) = annotateInContext Tail x
;
171 Takes an Expr
as an argument
and returns an Expr
, in which all variables that
172 have both a bound occurrence
and are set
in a set
!-expression are boxed
.
174 * Copying the variable from the stack to the heap
, right under the
175 lambda
-expression that defines the variable
176 * Changing all get operations to unbox
177 * Changing all set operations to box
-set
179 (* Returns the variables from
V (arg1
) that are set somewhere
in arg2
*)
180 fun filterSetVars
V (Var n
) = []
181 | filterSetVars
V (VarFree n
) = filterSetVars
V (Var n
)
182 | filterSetVars
V (VarBound (n
,_
,_
)) = filterSetVars
V (Var n
)
183 | filterSetVars
V (VarParam (n
,_
)) = filterSetVars
V (Var n
)
184 | filterSetVars
V (Const _
) = []
185 | filterSetVars
V (If (test
,dit
,dif
)) = union (map (filterSetVars V
) [test
,dit
,dif
])
186 | filterSetVars
V (Abs (P
,b
)) = filterSetVars (subtract V P
) b
187 | filterSetVars
V (AbsOpt (P
,opt
,b
)) = filterSetVars
V (Abs (P @
[opt
],b
))
188 | filterSetVars
V (AbsVar (opt
,b
)) = filterSetVars
V (Abs ([opt
],b
))
189 | filterSetVars
V (App (proc
,args
)) = union (map (filterSetVars V
) (proc
:: args
))
190 | filterSetVars
V (AppTP (proc
,args
)) = filterSetVars
V (App (proc
,args
))
191 | filterSetVars
V (Seq cnt
) = union (map (filterSetVars V
) cnt
)
192 | filterSetVars
V (Or preds
) = union (map (filterSetVars V
) preds
)
193 | filterSetVars
V (Set (Var n
,e
)) =
194 if isMember n V
then union
[[n
],filterSetVars V e
]
195 else filterSetVars V e
196 | filterSetVars
V (Set (VarFree n
,v
)) = filterSetVars
V (Set (Var n
,v
))
197 | filterSetVars
V (Set (VarBound (n
,_
,_
),v
)) = filterSetVars
V (Set (Var n
,v
))
198 | filterSetVars
V (Set (VarParam (n
,_
),v
)) = filterSetVars
V (Set (Var n
,v
))
199 | filterSetVars
V (Set (n
,v
)) = union (map (filterSetVars V
) [n
,v
])
200 | filterSetVars
V (Def (n
,v
)) = union (map (filterSetVars V
) [n
,v
])
201 (* Returns the free variables
in arg2
. arg1 is the list
of already
-bound vars
*)
202 and freeVarsIn
' BV (Var n
) = if isMember n BV
then [] else [n
]
203 | freeVarsIn
' BV (VarFree n
) = freeVarsIn
' BV (Var n
)
204 | freeVarsIn
' BV (VarBound (n
,_
,_
)) = freeVarsIn
' BV (Var n
)
205 | freeVarsIn
' BV (VarParam (n
,_
)) = freeVarsIn
' BV (Var n
)
206 | freeVarsIn
' BV (Const _
) = []
207 | freeVarsIn
' BV (If (test
,dit
,dif
)) = union (map (freeVarsIn
' BV
) [test
,dit
,dif
])
208 | freeVarsIn
' BV (Abs (P
,b
)) = freeVarsIn
' (union
[BV
,P
]) b
209 | freeVarsIn
' BV (AbsOpt (P
,opt
,b
)) = freeVarsIn
' BV (Abs (P @
[opt
],b
))
210 | freeVarsIn
' BV (AbsVar (opt
,b
)) = freeVarsIn
' BV (Abs ([opt
],b
))
211 | freeVarsIn
' BV (App (proc
,args
)) = union (map (freeVarsIn
' BV
) (proc
:: args
))
212 | freeVarsIn
' BV (AppTP (proc
,args
)) = freeVarsIn
' BV (App (proc
,args
))
213 | freeVarsIn
' BV (Seq cnt
) = union (map (freeVarsIn
' BV
) cnt
)
214 | freeVarsIn
' BV (Or preds
) = union (map (freeVarsIn
' BV
) preds
)
215 | freeVarsIn
' BV (Set (n
,v
)) = union (map (freeVarsIn
' BV
) [n
,v
])
216 | freeVarsIn
' BV (Def (n
,v
)) = union (map (freeVarsIn
' BV
) [n
,v
])
217 and freeVarsIn x
= freeVarsIn
' [] x
218 (* Returns the vars
of arg1 that have bound
-occurrences
in arg2
.
219 p has a bound
-occurrence
in b
<==> p has a free
-occurrence
in an
221 and filterBoundVars
P (e
as Abs (_
,_
)) = intersect
[(freeVarsIn e
),P
]
222 | filterBoundVars
P (e
as AbsOpt (_
,_
,_
)) = intersect
[(freeVarsIn e
),P
]
223 | filterBoundVars
P (e
as AbsVar (_
,_
)) = intersect
[(freeVarsIn e
),P
]
224 | filterBoundVars
P (If (test
,dit
,dif
)) = union (map (filterBoundVars P
) [test
,dit
,dif
])
225 | filterBoundVars
P (App (proc
,args
)) = union (map (filterBoundVars P
) (proc
:: args
))
226 | filterBoundVars
P (AppTP (proc
,args
)) = filterBoundVars
P (App (proc
,args
))
227 | filterBoundVars
P (Seq cnt
) = union (map (filterBoundVars P
) cnt
)
228 | filterBoundVars
P (Or cnt
) = union (map (filterBoundVars P
) cnt
)
229 | filterBoundVars
P (Set (n
,v
)) = union (map (filterBoundVars P
) [n
,v
])
230 | filterBoundVars
P (Def (n
,v
)) = union (map (filterBoundVars P
) [n
,v
])
231 | filterBoundVars _ _
= []
232 (* Returns the vars from arg1 that need to be boxed
in arg2
*)
233 and filterParamsToBox P b
= intersect
[(filterBoundVars P b
), (filterSetVars P b
)]
234 and makeBoxing name
= Set (Var name
,App (Var
"box", [Var name
]))
235 and makeBoxRead name
= App (Var
"vector-ref", [Var name
,Const (Number
0)])
236 and makeBoxWrite name ex
= App (Var
"vector-set!", [Var name
,Const (Number
0),ex
])
237 (* Traverses the expression arg2
and replaces
238 Var x
with (vector
-ref x
0)
239 Set (x
,v
) with (vector
-set
! x
0 v
)
240 for each x
in arg1
*)
241 and boxAccesses
[] x
= x
242 | boxAccesses
V (Set (Var n
,e
)) =
243 if isMember n V
then makeBoxWrite
n (boxAccesses V e
)
244 else Set (Var n
, boxAccesses V e
)
245 | boxAccesses
V (Var n
) =
246 if isMember n V
then makeBoxRead n
248 | boxAccesses
V (Abs (P
,b
)) = Abs(P
,boxAccesses (subtract V P
) b
)
249 | boxAccesses
V (AbsOpt (P
,opt
,b
)) = AbsOpt(P
,opt
,boxAccesses (subtract
V (opt
:: P
)) b
)
250 | boxAccesses
V (AbsVar (opt
,b
)) = AbsVar(opt
, boxAccesses (subtract V
[opt
]) b
)
251 | boxAccesses
V (If (test
,dit
,dif
)) = If (boxAccesses V test
,boxAccesses V dit
,boxAccesses V dif
)
252 | boxAccesses
V (App (proc
,args
)) = App (boxAccesses V proc
, map (boxAccesses V
) args
)
253 | boxAccesses
V (Seq cnt
) = Seq (map (boxAccesses V
) cnt
)
254 | boxAccesses
V (Or preds
) = Or (map (boxAccesses V
) preds
)
255 | boxAccesses
V (Set (v
,e
)) = Set (boxAccesses V v
,boxAccesses V e
)
256 | boxAccesses
V (Def (v
,e
)) = Def (boxAccesses V v
,boxAccesses V e
)
257 | boxAccesses _ e
= e
258 and isAbs (Abs _
) = true
259 |
isAbs (AbsOpt _
) = true
260 |
isAbs (AbsVar _
) = true
262 and boxSet (Abs (P
,b
)) =
264 val needBoxing
= filterParamsToBox P b
265 val boxingExprs
= map makeBoxing needBoxing
266 val fixedBody
= boxAccesses needBoxing b
267 val newBody
= Seq (boxingExprs @
[fixedBody
])
268 in Abs (P
,flattenSeq (boxSet newBody
)) end
269 |
boxSet (AbsOpt (P
,opt
,b
)) =
271 val needBoxing
= filterParamsToBox (opt
:: P
) b
272 val boxingExprs
= map makeBoxing needBoxing
273 val fixedBody
= boxAccesses needBoxing b
274 val newBody
= Seq (boxingExprs @
[fixedBody
])
275 in AbsOpt (P
,opt
,flattenSeq (boxSet newBody
)) end
276 |
boxSet (AbsVar (opt
,b
)) =
278 val needBoxing
= filterParamsToBox
[opt
] b
279 val boxingExprs
= map makeBoxing needBoxing
280 val fixedBody
= boxAccesses needBoxing b
281 val newBody
= Seq (boxingExprs @
[fixedBody
])
282 in AbsVar (opt
,flattenSeq (boxSet newBody
)) end
283 |
boxSet (If (test
,dit
,dif
)) = If (boxSet test
,boxSet dit
,boxSet dif
)
284 |
boxSet (App (proc
,args
)) = App (boxSet proc
,map boxSet args
)
285 |
boxSet (AppTP (proc
,args
)) = AppTP (boxSet proc
,map boxSet args
)
286 |
boxSet (Seq cnt
) = Seq (map boxSet cnt
)
287 |
boxSet (Or preds
) = Or (map boxSet preds
)
288 |
boxSet (Set (n
,v
)) = Set (boxSet n
,boxSet v
)
289 |
boxSet (Def (n
,v
)) = Def (boxSet n
,boxSet v
)
292 fun incMajors bounds
= map (fn VarBound(name
,major
,minor
) => VarBound(name
,major
+1,minor
)) bounds
293 and makeBoundVars params
= map (fn VarParam(name
,ndx
) => VarBound(name
,0,ndx
)) params
294 and makeParamVars
[] _
= []
295 |
makeParamVars (name
:: rest
) ndx
= VarParam(name
,ndx
) :: (makeParamVars
rest (ndx
+1))
296 and lookupVar varname
[] = VarFree(varname
)
297 | lookupVar
varname (VarParam(name
,ndx
) :: rest
) =
298 if varname
=name
then VarParam(name
,ndx
)
299 else lookupVar varname rest
300 | lookupVar
varname (VarBound(name
,major
,minor
) :: rest
) =
301 if varname
=name
then VarBound(name
,major
,minor
)
302 else lookupVar varname rest
303 | lookupVar
varname (_
:: rest
) = lookupVar varname rest
304 and annotateVars bounds
params (Abs(p
,b
)) =
305 Abs(p
, annotateVars ((makeBoundVars params
) @
(incMajors bounds
)) (makeParamVars p
0) b
)
306 | annotateVars bounds
params (AbsOpt(p
,opt
,b
)) =
307 AbsOpt(p
, opt
, annotateVars ((makeBoundVars params
) @
(incMajors bounds
)) (makeParamVars (p @
[opt
]) 0) b
)
308 | annotateVars bounds
params (AbsVar(opt
,b
)) =
309 AbsVar(opt
, annotateVars ((makeBoundVars params
) @
(incMajors bounds
)) (makeParamVars
[opt
] 0) b
)
310 | annotateVars bounds
params (If(test
,dit
,dif
)) =
311 If( (annotateVars bounds params test
), (annotateVars bounds params dit
), (annotateVars bounds params dif
) )
312 | annotateVars bounds
params (App(proc
,args
)) = App( (annotateVars bounds params proc
), map (annotateVars bounds params
) args
)
313 | annotateVars bounds
params (AppTP(proc
,args
)) = AppTP( (annotateVars bounds params proc
), map (annotateVars bounds params
) args
)
314 | annotateVars bounds
params (Seq(cnt
)) = Seq( map (annotateVars bounds params
) cnt
)
315 | annotateVars bounds
params (Or(preds
)) = Or( map (annotateVars bounds params
) preds
)
316 | annotateVars bounds
params (Set(n
,v
)) = Set( (annotateVars bounds params n
), (annotateVars bounds params v
) )
317 | annotateVars bounds
params (Def(n
,v
)) = Def( (annotateVars bounds params n
), (annotateVars bounds params v
) )
318 | annotateVars bounds
params (Var(name
)) = lookupVar
name (params @ bounds
)
319 | annotateVars bounds params x
= x
320 and lexicalAddressing(x
) = annotateVars
[] [] x
;
322 val semanticAnalysis
=
326 (* checkDefineContexts
o *)
329 end; (* of struct SemanticAnalysis
*)