|
1 "{ Package: 'stx:goodies/petitparser/compiler' }" |
|
2 |
|
3 Object subclass:#PPCCompiler |
|
4 instanceVariableNames:'compilerStack compiledParser cache inlining debug profile |
|
5 currentMethod lastMethod guards ids updateContextMethod tokenMode' |
|
6 classVariableNames:'' |
|
7 poolDictionaries:'' |
|
8 category:'PetitCompiler-Core' |
|
9 ! |
|
10 |
|
11 PPCCompiler comment:'' |
|
12 ! |
|
13 |
|
14 !PPCCompiler methodsFor:'accessing'! |
|
15 |
|
16 fastMode |
|
17 ^ tokenMode |
|
18 ! |
|
19 |
|
20 inlining |
|
21 ^ inlining |
|
22 ! |
|
23 |
|
24 inlining: value |
|
25 inlining := value |
|
26 ! |
|
27 |
|
28 lastMethod |
|
29 ^ lastMethod |
|
30 ! |
|
31 |
|
32 parameters: associations |
|
33 | key value | |
|
34 associations do: [ :ass | |
|
35 key := ass key. |
|
36 value := ass value. |
|
37 |
|
38 (key = #profile) ifTrue: [ profile := value ]. |
|
39 (key = #inline) ifTrue: [ inlining := value ]. |
|
40 (key = #guards) ifTrue: [ guards := value ]. |
|
41 ] |
|
42 ! |
|
43 |
|
44 profile |
|
45 ^ profile |
|
46 ! |
|
47 |
|
48 profile: aBoolean |
|
49 profile := aBoolean |
|
50 ! |
|
51 |
|
52 startInline: id |
|
53 self push. |
|
54 |
|
55 currentMethod := PPCInlinedMethod new. |
|
56 currentMethod id: id. |
|
57 currentMethod profile: self profile. |
|
58 ! ! |
|
59 |
|
60 !PPCCompiler methodsFor:'cleaning'! |
|
61 |
|
62 clean: class |
|
63 " Transcript crShow: 'Cleaning time: ', |
|
64 [ |
|
65 " self cleanGeneratedMethods: class. |
|
66 self cleanInstVars: class. |
|
67 self cleanParsers: class. |
|
68 self cleanConstants: class. |
|
69 " ] timeToRun asMilliSeconds asString, 'ms'." |
|
70 ! |
|
71 |
|
72 cleanConstants: class |
|
73 class constants removeAll. |
|
74 ! |
|
75 |
|
76 cleanGeneratedMethods: class |
|
77 (class allSelectorsInProtocol: #generated) do: [ :selector | |
|
78 class removeSelectorSilently: selector ]. |
|
79 ! |
|
80 |
|
81 cleanInstVars: class |
|
82 class class instanceVariableNames: ''. |
|
83 ! |
|
84 |
|
85 cleanParsers: class |
|
86 class parsers removeAll. |
|
87 ! ! |
|
88 |
|
89 !PPCCompiler methodsFor:'code generation'! |
|
90 |
|
91 add: string |
|
92 currentMethod add: string. |
|
93 ! |
|
94 |
|
95 addConstant: value as: name |
|
96 compiledParser addConstant: value as: name. |
|
97 ! |
|
98 |
|
99 addOnLine: string |
|
100 currentMethod addOnLine: string. |
|
101 ! |
|
102 |
|
103 addVariable: name |
|
104 currentMethod addVariable: name. |
|
105 ! |
|
106 |
|
107 allowInline |
|
108 currentMethod allowInline |
|
109 ! |
|
110 |
|
111 cache: id as: value |
|
112 cache at: id put: value. |
|
113 ! |
|
114 |
|
115 cachedValue: id |
|
116 ^ cache at: id ifAbsent: [ nil ] |
|
117 ! |
|
118 |
|
119 call: anotherMethod |
|
120 currentMethod add: anotherMethod call. |
|
121 ! |
|
122 |
|
123 callOnLine: anotherMethod |
|
124 currentMethod addOnLine: anotherMethod call. |
|
125 ! |
|
126 |
|
127 checkCache: id |
|
128 | method value | |
|
129 "Check if method is already compiled/hand written" |
|
130 method := compiledParser compiledMethodAt: id ifAbsent: [ nil ]. |
|
131 method ifNotNil: [ ^ lastMethod := PPCCompiledMethod new id: id; yourself ]. |
|
132 |
|
133 ^ (value := self cachedValue: id) ifNotNil: [ lastMethod := value ]. |
|
134 ! |
|
135 |
|
136 dedent |
|
137 currentMethod dedent |
|
138 ! |
|
139 |
|
140 indent |
|
141 currentMethod indent |
|
142 ! |
|
143 |
|
144 nl |
|
145 currentMethod nl |
|
146 ! |
|
147 |
|
148 pop |
|
149 | array | |
|
150 array := compilerStack pop. |
|
151 currentMethod := array first |
|
152 ! |
|
153 |
|
154 push |
|
155 | array | |
|
156 array := { currentMethod }. |
|
157 compilerStack push: array. |
|
158 (compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ] |
|
159 ! |
|
160 |
|
161 smartRemember: parser |
|
162 ^ self smartRemember: parser to: #memento |
|
163 ! |
|
164 |
|
165 smartRemember: parser to: variableName |
|
166 parser isContextFree ifTrue: [ |
|
167 ^ variableName, ' := context lwRemember.'. |
|
168 ]. |
|
169 ^ variableName, ':= context remember.' |
|
170 ! |
|
171 |
|
172 smartRestore: parser |
|
173 ^ self smartRestore: parser from: #memento |
|
174 ! |
|
175 |
|
176 smartRestore: parser from: mementoName |
|
177 parser isContextFree ifTrue: [ |
|
178 ^ 'context lwRestore: ', mementoName, '.'. |
|
179 ]. |
|
180 ^ 'context restore: ', mementoName, '.'. |
|
181 ! |
|
182 |
|
183 startMethod: id |
|
184 | sender | |
|
185 (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. |
|
186 self push. |
|
187 |
|
188 |
|
189 currentMethod := PPCMethod new. |
|
190 currentMethod id: id. |
|
191 currentMethod profile: self profile. |
|
192 self cache: id as: currentMethod. |
|
193 |
|
194 sender := thisContext sender receiver. |
|
195 self add: '"Method generated from ', sender asString, '"'. |
|
196 ! |
|
197 |
|
198 startTokenMode |
|
199 tokenMode := true |
|
200 ! |
|
201 |
|
202 stopInline |
|
203 | sender | |
|
204 sender := thisContext sender receiver. |
|
205 self add: '"Inlined by ', sender asString, '"'. |
|
206 lastMethod := currentMethod. |
|
207 currentMethod := nil. |
|
208 self pop. |
|
209 ! |
|
210 |
|
211 stopMethod |
|
212 self cache: currentMethod methodName as: currentMethod. |
|
213 lastMethod := currentMethod. |
|
214 currentMethod := nil. |
|
215 self pop. |
|
216 ! |
|
217 |
|
218 stopTokenMode |
|
219 tokenMode := false |
|
220 ! ! |
|
221 |
|
222 !PPCCompiler methodsFor:'code generation - ids'! |
|
223 |
|
224 idFor: object prefixed: prefix |
|
225 ^ self idFor: object prefixed: prefix effect: #none |
|
226 ! |
|
227 |
|
228 idFor: object prefixed: prefix effect: effect |
|
229 | body suffix | |
|
230 ^ ids at: object ifAbsentPut: [ |
|
231 suffix := self fastMode ifTrue: [ '_fast' ] ifFalse: [ '' ]. |
|
232 ((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ |
|
233 (object name, suffix) asSymbol |
|
234 ] ifFalse: [ |
|
235 body := ids size asString. |
|
236 (prefix asString, '_', body, suffix) asSymbol |
|
237 ] |
|
238 ] |
|
239 ! |
|
240 |
|
241 idFor: object prefixed: prefix suffixed: suffix effect: effect |
|
242 | body | |
|
243 ^ ids at: object ifAbsentPut: [ |
|
244 ((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ |
|
245 (object name, suffix) asSymbol |
|
246 ] ifFalse: [ |
|
247 body := ids size asString. |
|
248 (prefix asString, '_', body, suffix) asSymbol |
|
249 ] |
|
250 ] |
|
251 ! ! |
|
252 |
|
253 !PPCCompiler methodsFor:'compiling'! |
|
254 |
|
255 compile: aPPParser as: name |
|
256 ^ self compile: aPPParser as: name params: #() |
|
257 ! |
|
258 |
|
259 compile: aPPParser as: name params: params |
|
260 | parser | |
|
261 parser := self copy: aPPParser. |
|
262 parser := self toCompilerTree: parser. |
|
263 parser := self optimize: parser params: params. |
|
264 parser := self compileTree: parser as: name parser: aPPParser params: params. |
|
265 ^ parser |
|
266 |
|
267 ! |
|
268 |
|
269 compileTree: compilerTree as: name parser: parser params: params |
|
270 | | |
|
271 params do: [ :p | |
|
272 (p key = #guards) ifTrue: [ self guards: p value ]. |
|
273 ]. |
|
274 |
|
275 " |
|
276 To create a new Package so that a new classes are not in PetitCompiler package. |
|
277 TODO JK: This is HACK, needs some more interoperable approach |
|
278 " |
|
279 RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'. |
|
280 compiledParser := (Smalltalk at: name ifAbsent: [ nil ]). |
|
281 compiledParser ifNil: [ |
|
282 PPCompiledParser subclass: name. |
|
283 compiledParser := Smalltalk at: name. |
|
284 compiledParser category: 'PetitCompiler-Generated' |
|
285 ] ifNotNil: [ |
|
286 self clean: compiledParser |
|
287 ]. |
|
288 compiledParser constants removeAll. |
|
289 |
|
290 |
|
291 |
|
292 self startMethod: #start. |
|
293 self add: '^ '. |
|
294 self callOnLine: (compilerTree compileWith: self). |
|
295 self stopMethod. |
|
296 |
|
297 self installMethodsAndVariables: compiledParser. |
|
298 |
|
299 compiledParser referringParser: parser. |
|
300 ^ compiledParser |
|
301 ! |
|
302 |
|
303 copy: parser |
|
304 ^ parser transform: [ :p | p copy ]. |
|
305 ! |
|
306 |
|
307 installMethods: class |
|
308 cache keysAndValuesDo: [ :key :method | |
|
309 class compileSilently: method code classified: 'generated'. |
|
310 ] |
|
311 ! |
|
312 |
|
313 installMethodsAndVariables: class |
|
314 |
|
315 self installVariables: class. |
|
316 self installMethods: class. |
|
317 |
|
318 ! |
|
319 |
|
320 installVariables: class |
|
321 | string | |
|
322 string := class constants keys inject: '' into: [:r :e | r, ' ', e ]. |
|
323 PPCompiledParser subclass: class name instanceVariableNames: string classVariableNames: '' category: 'PetitCompiler-Generated'. |
|
324 ! |
|
325 |
|
326 optimize: parser params: params |
|
327 | retval | |
|
328 retval := parser optimizeTree: params. |
|
329 retval checkTree. |
|
330 ^ retval |
|
331 ! |
|
332 |
|
333 toCompilerTree: parser |
|
334 ^ parser asCompilerTree |
|
335 ! ! |
|
336 |
|
337 !PPCCompiler methodsFor:'guard'! |
|
338 |
|
339 addSequenceGuard: parser |
|
340 |
|
341 | firsts guardSet guardSetId | |
|
342 (self guards not or: [(guardSet := self guardCharSet: parser) isNil]) ifTrue: [ ^ self]. |
|
343 |
|
344 firsts := (parser firstSetSuchThat: [ :e | (e isKindOf: PPTokenParser) or: [ e isTerminal ] ]). |
|
345 |
|
346 "If we start with PPTokenParser, we should invoke the whitespace parser" |
|
347 (firsts allSatisfy: [ :e | e isKindOf: PPTokenParser ]) ifTrue: [ |
|
348 guardSetId := (self idFor: guardSet prefixed: #guard). |
|
349 self addConstant: guardSet as: guardSetId. |
|
350 self add: 'wsParser parseOn: context.'. |
|
351 self add: 'context atEnd ifTrue: [ ^ self error ].'. |
|
352 self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'. |
|
353 ]. |
|
354 |
|
355 (firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [ |
|
356 guardSetId := (self idFor: guardSet prefixed: #guard). |
|
357 self addConstant: guardSet as: guardSetId. |
|
358 self add: 'context atEnd ifTrue: [ ^ self error ].'. |
|
359 self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'. |
|
360 ]. |
|
361 ! |
|
362 |
|
363 guardCharSet: parser |
|
364 | fs charSet | |
|
365 "No Guards fro trimming parser so far" |
|
366 (parser firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty ifFalse: [ ^ nil ]. |
|
367 |
|
368 "Makes no sense to do guard for epsilon parse" |
|
369 (parser acceptsEpsilon) ifTrue: [ ^ nil ]. |
|
370 |
|
371 fs := parser firstSet. |
|
372 fs do: [ :p | |
|
373 "If we can accept epsilon guard does not make sense" |
|
374 p isNullable ifTrue: [ ^ nil ]. |
|
375 ]. |
|
376 |
|
377 charSet := PPCharSetPredicate on: [:char | fs anySatisfy: [:e | (e firstCharParser parse: char asString) isPetitFailure not ]]. |
|
378 ^ charSet |
|
379 ! |
|
380 |
|
381 guards |
|
382 ^ guards |
|
383 ! |
|
384 |
|
385 guards: aBoolean |
|
386 guards := aBoolean |
|
387 ! ! |
|
388 |
|
389 !PPCCompiler methodsFor:'initialization'! |
|
390 |
|
391 initialize |
|
392 super initialize. |
|
393 compilerStack := Stack new. |
|
394 cache := IdentityDictionary new. |
|
395 ids := IdentityDictionary new. |
|
396 |
|
397 tokenMode := false. |
|
398 inlining := true. |
|
399 profile := false. |
|
400 guards := true. |
|
401 ! ! |
|
402 |
|
403 !PPCCompiler methodsFor:'ppcmethod protocol'! |
|
404 |
|
405 bridge |
|
406 ^ PPCBridge on: lastMethod methodName. |
|
407 ! |
|
408 |
|
409 call |
|
410 ^ lastMethod call |
|
411 ! |
|
412 |
|
413 canInline |
|
414 ^ lastMethod canInline |
|
415 ! ! |
|
416 |