1.

;;;----------------------------------------------------------------------------

2. ;;; Update to NODE.SCM abstractions to handle FUNREC:

3. ;;;

4. ;;; (funrec ((I1 (lambda (I*) E_1))

5. ;;; ...

6. ;;; (In (lambda (I*) E_n)))

7. ;;; E_body)

8. ;;;

9. (define (funrec-node? node)

10. (eq? (node-type node) 'funrec))

11. (define (make-funrec names lams body)

12. `(FUNREC ,(map (lambda (name lam) `(,name ,lam))

i. names

ii. lams)

b. ,body))

13. (define (funrec-names node)

14. (map first (second node)))

15. (define (funrec-lambdas node)

16. (map second (second node)))

17. (define (funrec-body node)

18. (third node))

19. (define *special-forms*

20. '(program lambda call if set! begin quote primop let

21. define ; Only should be a top-level

22. define-global global-ref global-set! ; Introduced by globalizing

23. call-generic call-closure

26. unspecific null

27. error syscall

28. code call-code

29. funrec ; ***

30. ))

31. (define (subnodes node)

32. (cond

33. ((leaf-node? node) '())

34. ((lambda-node? node) (list (lambda-body node)))

35. ; ((simple-let-node? node)

36. ; (cons (simple-let-body node) (simple-let-defs node)))

37. ((let-node? node)

38. (cons (let-body node) (let-defs node)))

39. ((application-node? node) (application-subexps node))

40. ((primop-node? node) (primop-args node))

41. ((syscall-node? node) (syscall-args node))

42. ((assignment-node? node) (list (assignment-body node)))

43. ((program-node? node)

44. (cons (program-body node) (map definition-body node)))

45. ((funrec-node? node)

46. (cons (funrec-body node) (funrec-lambdas node)))

47. (else (node-subexps node))))

48. (define (subnode-map fn node)

49. ;;

50. ;; For compound (non-leaf) nodes, return a new compound node in which

51. ;; FN has been applied to each subnode. Has no effect on leaf nodes.

52. ;;

53. (cond

54. ((leaf-node? node) node)

55. ((lambda-node? node)

56. (make-lambda (lambda-formals node)

a. (fn (lambda-body node))))

57. ((let-node? node)

58. (make-let (let-names node)

a. (map fn (let-defs node))

b. (fn (let-body node))))

59. ((assignment-node? node)

60. (new-assignment node (fn (assignment-body node))))

61. ((primop-node? node)

62. (make-primop (primop-op node)

a. (map fn (primop-args node))))

63. ((syscall-node? node)

64. (make-syscall (syscall-op node)

a. (map fn (syscall-args node))))

65. ((program-node? node)

66. (let ((defs (program-defs node)))

67. (make-program

68. (map new-definition defs (map (compose fn definition-body) defs))

69. (fn (program-body node)))))

70. ;;; *** NEW ***

71. ((funrec-node? node)

72. (make-funrec (funrec-names node)

i. (map fn (funrec-lambdas node))

ii. (fn (funrec-body node))))

73. ;; ************

74. (else (make-node (node-keyword node)

i. (map fn (node-subexps node))))

75. ))

76. (define (subnode-map-receive fn node leaf receive)

77. ;;

78. ;; Generalized version of SUBNODE-MAP that allows the return of

79. ;; multiple results in a recursive tree accumulation over a node tree.

80. ;; At any node, applies RECEIVE to:

81. ;;

82. ;; (i) A node-making procedure specialized for the node that

83. ;; expects new subnodes as arguments.

84. ;; (ii) A rest arg that is the result of applying FN to all of the

85. ;; subnodes. In general, FN will return a compound structure only

86. ;; one component of which is the new node.

87. ;;

88. ;; Since leaf nodes have no subnodes, the LEAF procedure is applied

89. ;; to leaf nodes to generate the appropriate base case for the

90. ;; recursive tree accumuation.

91. ;;

92. (cond

93. ((leaf-node? node)

94. (receive (lambda (ignore) node)

a. (leaf node)))

95. ((lambda-node? node)

96. (receive (lambda (body) (make-lambda (lambda-formals node) body))

a. (fn (lambda-body node))))

97. ((let-node? node)

98. (apply receive

99. (lambda (new-body . new-defs)

a. (make-let (let-names node) new-defs new-body))

b. (map fn (cons (let-body node) (let-defs node)))))

100. ((assignment-node? node)

101. (receive (lambda (body) (new-assignment node body))

a. (fn (assignment-body node))))

102. ((primop-node? node)

103. (apply receive

104. (lambda new-args (make-primop (primop-op node) new-args))

105. (map fn (primop-args node))))

106. ((syscall-node? node)

107. (apply receive

108. (lambda new-args (make-syscall (syscall-op node) new-args))

109. (map fn (syscall-args node))))

110. ((program-node? node)

111. (let ((defs (program-defs node)))

112. (apply receive

a. (lambda (new-body . new-def-bodies)

i. (make-program (map new-definition defs new-def-bodies)

1. new-body))

 b. (map fn (cons (program-body node)

1. (map define-body defs))))))

113. ;; *** NEW ***

114. ((funrec-node? node)

115. (apply receive

a. (lambda (new-body . new-lambdas)

b. (make-funrec (funrec-names node)

1. new-lambdas

2. new-body))

c. (map fn (cons (funrec-body node) (funrec-lambdas node)))))

116. ;; ***********

117. (else

118. (apply receive

119. (lambda new-subnodes (make-node (node-keyword node) new-subnodes))

120. (map fn (node-subexps node))))

121. ))

122. (define (rewrite vars rewrite-ref rewrite-set! node)

123. ;;

124. ;; A simple substitution routine.

125. ;; For each X in the set VARS of variable names:

126. ;; (i) replace every reference to X in NODE by the result of

127. ;; (REWRITE-REF X).

128. ;; (ii) replace every (SET! X <body>) in NODE by the result of

129. ;; (REWRITE-SET! X <rewritten-body>)

130. ;;

131. ;; Neither REWRITE-REF and REWRITE-SET! should return nodes with

names

132. ;; that might be captured by enclosing lambdas.

133. ;;

134. (let walk ((vars vars)

a. (node node))

135. (cond

136. ((set-empty? vars) node) ;; Optimization

137. ((and (var-node? node) (set-member? (var-name node) vars))

138. (rewrite-ref (var-name node)))

139. ((and (set!-node? node) (set-member? (set!-name node) vars))

140. (rewrite-set! (set!-name node)

i. (walk vars (set!-body node))))

141. ((lambda-node? node)

142. (let ((formals (lambda-formals node)))

143. (make-lambda formals

i. (walk (set-difference vars (list->set formals))

ii. (lambda-body node)))))

144. ((let-node? node)

145. (let ((names (let-names node)))

146. (make-let names

i. (map (lambda (def) (walk vars def))

ii. (let-defs node))

iii. (walk (set-difference vars (list->set names))

1. (let-body node)))))

147. ((program-node? node)

148. (let* ((defs (program-defs node))

a. (names (map definition-names defs))

b. (new-vars (set-difference vars (list->set names))))

149. (make-program

a. (map (lambda (def)

i. (new-definition def

a. (walk new-vars (definition-body def))))

b. defs)

c. (walk new-vars (program-body node)))))

150. ;; *** NEW ***

151. ((funrec-node? node)

152. (let ((new-vars (set-difference vars

a. (list->set (funrec-names node)))))

153. (make-funrec (funrec-names node)

i. (map (lambda (def) (walk new-vars def))

1. (funrec-lambdas node))

ii. (walk new-vars (funrec-body node)))))

154. ;; **********

155. (else (subnode-map (lambda (n) (walk vars n)) node))

156. )))

157. (define (free-vars node)

158. (cond

159. ((var-node? node) (set-singleton (var-name node)))

160. ((assignment-node? node)

161. (set-union (set-singleton (assignment-name node))

i. (free-vars (assignment-body node))))

162. ((lambda-node? node)

163. (set-difference (free-vars (lambda-body node))

i. (list->set (lambda-formals node))))

164. ((let-node? node)

165. (set-union (map-union free-vars (let-defs node))

i. (set-difference (free-vars (let-body node))

a. (list->set (let-names node)))))

166. ((program-node? node)

167. (set-difference

168. (set-union

169. (map-union free-vars (map define-body (program-defs node)))

170. (free-vars (program-body node)))

171. (list->set (map define-name (program-defs node)))))

172. ;; *** NEW ***

173. ((funrec-node? node)

174. (set-difference

175. (set-union (map-union free-vars (funrec-lambdas node))

i. (free-vars (funrec-body node)))

176. (list->set (funrec-names node))))

177. ;; ***********

178. (else (map-union free-vars (subnodes node)))

179. ))

180. (define (free-mutables node)

181. ;;

182. ;; New function (not in NODE.SCM).

183. ;; Finds all free vars in node that are assigned via SET!

184. ;;

185. (cond

186. ((var-node? node) the-empty-set)

187. ((assignment-node? node)

188. (set-union (set-singleton (assignment-name node))

i. (free-mutables (assignment-body node))))

189. ((lambda-node? node)

190. (set-difference (free-mutables (lambda-body node))

i. (list->set (lambda-formals node))))

191. ((let-node? node)

192. (set-union (map-union free-mutables (let-defs node))

i. (set-difference (free-mutables (let-body node))

 a. (list->set (let-names node)))))

193. ((program-node? node)

194. (set-difference

195. (set-union

196. (map-union free-mutables (map define-body (program-defs node)))

197. (free-mutables (program-body node)))

198. (list->set (map define-name (program-defs node)))))

199. ;; *** NEW ***

200. ((funrec-node? node)

201. (set-difference

202. (set-union (map-union free-mutables (funrec-lambdas node))

i. (free-mutables (funrec-body node)))

203. (list->set (funrec-names node))))

204. ;; ***********

205. (else (map-union free-mutables (subnodes node)))

206. ))

207. ;;;----------------------------------------------------------------------------

208. ;;; New implementation of closures supporting %CLOSURE-SHIFT to

work

209. (define closure-tag '(closure))

210. (define (%closure . elts)

211. (vector closure-tag 0 (apply vector elts)))

212. (define (%closure-ref closure index)

213. (closure-check-index closure index)

214. (vector-ref (vector-ref closure 2)

i. (+ index (vector-ref closure 1))))

215. (define (%closure-set! closure index new)

216. (closure-check-index closure index)

217. (vector-set! (vector-ref closure 2)

i. (+ index (vector-ref closure 1))

ii. new))

218. (define (closure-check-index closure index)

219. (let ((elts (vector-ref closure 2))

220. (real-index (+ index (vector-ref closure 1))))

221. (if (or (< real-index 0)

a. (>= real-index (vector-length elts)))

222. (error "CLOSURE: index out of range -- " index))))

223. (define (%closure-shift closure offset)

224. ;;

225. ;; Effectively returns a pointer into the middle of the closure.

226. ;; Note that the result shares structure with the input.

227. ;;

228. (let ((new-offset (+ offset (vector-ref closure 1)))

229. (elts (vector-ref closure 2)))

230. (if (or (< new-offset 0)

a. (>= new-offset (vector-length elts)))

231. (error "CLOSURE-SHIFT: Offset out of range -- " (list closure offset))

232. (vector closure-tag new-offset elts))))

233. (define (%closure? obj)

234. (and (vector? obj)

235. (= (vector-length obj) 3)

236. (eq? (vector-ref obj 0) closure-tag)))

237. ;;;----------------------------------------------------------------------------

238. ;;; Extension to DESUGAR.SCM to catch assignments to FUNREC names

239. ;;; (which are illegal).

240. (define-sugar 'funrec

241. (lambda (exp)

242. (define (lambda-exp? exp)

243. (and (list? exp)

a. (>= (length exp) 3)

b. (eq? (car exp) 'lambda)))

244. (define (check-lambda exp)

245. (if (not (lambda-exp? exp))

a. (error "FUNREC: non-lambda expression" exp)

b. exp))

246. (let ((bindings (second exp))

a. (body-exps (cddr exp)))

247. (let ((names (map first bindings))

a. (lams (map (compose check-lambda second) bindings)))

248. (let ((new-lams (map desugar lams))

a. (new-body (make-desugared-begin

1. (map desugar body-exps))))

b. (let ((illegal-mutables

i. (set-intersection

ii. (list->set names)

iii. (map-union free-mutables

1. (cons new-body new-lams)))))

c. (if (not (set-empty? illegal-mutables))

i. (error "SYNTAX ERROR: FUNREC contains illegal assignments"

ii. illegal-mutables)

iii. `(FUNREC ,(map (lambda (name lam) `(,name ,lam))

a. names

b. new-lams)

2. ,new-body))))))))

249. ;;;----------------------------------------------------------------------------

250. ;;; GLOBALIZE and ASSIGNMENT CONVERSION phases don't need

to change.

251. ;;;----------------------------------------------------------------------------

252. ;;; CPS-CONVERSION phase:

253. ;;; Modify CPS to dispatch to CPS-FUNREC (below)

254. (define (cps node mcont)

255. ;; MCONT here is a "meta-continuation" that maps a lettable value

256. ;; (i.e., syntactic class W) into a syntactic continuation.

257. (cond

258. ((leaf-node? node) (mcont node))

259. ((lambda-node? node) (cps-lambda node mcont))

260. ((let-node? node) (cps-let node mcont))

261. ((application-node? node) (cps-application node mcont))

262. ((conditional-node? node) (cps-conditional node mcont))

263. ((assignment-node? node) (cps-assignment node mcont))

264. ((primop-node? node) (cps-primop node mcont))

265. ((syscall-node? node) (cps-syscall node mcont))

266. ((program-node? node) (cps-program node mcont))

267. ((funrec-node? node) (cps-funrec node mcont))

268. ;; ((begin-node? node) (cps-begin node mcont)) ; No longer supported

269. (else (error "CPS: Don't know how to handle node:" node))))

270. (define (cps-funrec node mcont)

271. ;; Patterned after CPS-PROGRAM:

272. (cps-list (funrec-lambdas node)

a. (lambda (Vs) ;; Guaranteed to be Vs because all are lambdas

b. (make-funrec (funrec-names node)

1. Vs

2. (cps (funrec-body node) mcont)))))

273. ;;;----------------------------------------------------------------------------

274. ;;; Extension to RUNTIME.SCM to make FUNREC desugar into a

LETREC within Scheme

275. ; The local version

276. (define-syntax define-syntax-global

277. (macro (name expander)

278. `(begin

279. (define-syntax ,name ,expander)

280. (syntax-table-define system-global-syntax-table ',name ,expander))))

281. ; The exported version

282. (syntax-table-define system-global-syntax-table

283. 'define-syntax-global

284. (macro (name expander)

285. `(begin

286. (define-syntax ,name ,expander)

287. (syntax-table-define system-global-syntax-table ',name ,expander))))

288. (define-syntax-global define-macro-global

289. (macro (pattern . body)

290. `(DEFINE-SYNTAX-GLOBAL ,(car pattern)

291. (MACRO ,(cdr pattern) ,@body))))

292. (define-macro-global (funrec bindings . body)

293. `(LETREC ,bindings ,@body))

294. ;;;----------------------------------------------------------------------------

295. ;;; Names for compiler passes

296. (define ->desugar (cascade initialize desugar abbreviate pp))

297. (define ->globalize (cascade initialize desugar globals/wrap abbreviate

pp))

298. (define ->assign (cascade initialize desugar globals/wrap assignment-

convert

1. abbreviate pp))

299. (define ->cps (cascade initialize desugar globals/wrap assignment-convert

i. cps-convert abbreviate pp))

300. ;; Note: the following passes don't include an ORDER-CONVERT at the

end,

301. ;; but they could.

302. (define ->closures (cascade initialize desugar globals/wrap assignment-

convert

1. cps-convert closurize abbreviate pp))

303. (define ->closures/no-cps

304. (cascade initialize desugar globals/wrap assignment-convert

a. closurize abbreviate pp))

305. (define ->lift (cascade initialize desugar globals/wrap assignment-convert

1. cps-convert closurize lift-convert

2. abbreviate pp))

306. (define ->data (cascade initialize desugar globals/wrap assignment-convert

1. cps-convert closurize lift-convert

2. data-convert data-unconvert abbreviate pp))

307. ;;;----------------------------------------------------------------------------

308. ;;; Code for the even/odd example:

309. (define even/odd

310. '(funrec ((even? (lambda (a) (if (= 0 a)

a. #t

b. (odd? (- a 1)))))

b. (odd? (lambda (b) (if (= 0 b)

a. #f

b. (even? (- b 1))))))

c. (even? 2)))