core.scm (11073B)
1 ;;;; core.scm 2 3 4 (define (add-undefined var) 5 (unless (memq var undefined) 6 (set! undefined (cons var undefined)))) 7 8 (define (add-access var assign) 9 (let ((d (get var 'defined))) 10 (if d 11 (when (and (symbol? d) (not (memq d used-sections))) 12 (set! used-sections (cons d used-sections))) 13 (add-undefined var)) 14 (cond (assign 15 (unless (get var 'assigned) 16 (put! var 'assigned #t) 17 (set! assigned (cons var assigned)))) 18 ((not (get var 'referenced)) 19 (put! var 'referenced #t) 20 (set! referenced (cons var referenced)))))) 21 22 (define (canonicalize form state) 23 (let ((looping #f) 24 (debug-mode (test-option 'debug state)) 25 (xref-mode (test-option 'xref state)) 26 (strict-mode (test-option 'strict state))) 27 (define (match-llist? llist args) 28 (let loop ((ll llist) (args args)) 29 (cond ((null? ll) (null? args)) 30 ((symbol? ll)) 31 ((null? args) #f) 32 (else (loop (cdr ll) (cdr args)))))) 33 (define (dotted? name) 34 (string-find-char #\. (stringify name))) 35 (define (normalize-ref ref) 36 (let* ((str (stringify ref)) 37 (len (string-length str))) 38 (cond ((char=? #\. (string-ref str 0)) 39 (normalize-ref (substring str 1 len))) 40 ((char=? #\. (string-ref str (- len 1))) 41 (normalize-ref (substring str 0 (- len 1)))) 42 (else str)))) 43 (define (walk x e tail ldest) 44 ;;(pp x) 45 (match x 46 ((or (? char?) (? number?) (? string?) (? boolean?)) 47 `(quote ,x)) 48 ((? symbol?) 49 (if (and (not strict-mode) (dotted? x)) 50 (let ((str (symbol->string x))) 51 (cond ((char=? #\. (string-ref str 0)) 52 `(%property-ref ,(normalize-ref str))) 53 (else 54 `(%host-ref ,(normalize-ref str))))) 55 (cond ((assq x e) => cdr) 56 (else 57 (when xref-mode (add-access x #f)) 58 `(%global-ref ,x))))) 59 (('set! x y) 60 (let ((y (walk y e #f #f))) 61 (if (and (not strict-mode) (dotted? x)) 62 `(%host-set! ,(normalize-ref x) ,y) 63 (cond ((assq x e) => (lambda (a) `(set! ,(cdr a) ,y))) 64 (else 65 (when xref-mode 66 (put! x 'assigned #t) 67 (add-access x #t)) 68 `(%global-set! ,x ,y)))))) 69 (('quote _) x) 70 (('if x y) 71 `(if ,(walk x e #f #f) 72 ,(walk y e tail ldest) 73 (%void))) 74 (('if x y z) 75 `(if ,(walk x e #f #f) 76 ,(walk y e tail ldest) 77 ,(walk z e tail ldest))) 78 ((('lambda _ ('%dispatch lambdas ...)) args ...) 79 (let loop ((ls lambdas)) 80 (if (or (null? (cdr ls)) 81 (match-llist? (cadar ls) args)) 82 (walk `(,(car ls) ,@args) e tail ldest) 83 (loop (cdr ls))))) 84 ((('lambda () body ...)) 85 (walk `(begin ,@body) e #t ldest)) 86 ((('lambda llist body ...) args ...) 87 (match-let (((vars rest) (parse-llist llist))) 88 (let ((aliases (map (lambda (v) (cons v (temp))) vars))) 89 (let loop ((as aliases) (vars vars) (args args)) 90 (cond ((null? as) 91 ;; handle surplus arguments 92 (let loop2 ((args args)) 93 (if (null? args) 94 (walk 95 `(begin ,@body) 96 (append aliases e) 97 tail ldest) 98 `(let ((%unused ,(walk (car args) e #f #f))) 99 ,(loop2 (cdr args)))))) 100 ((eq? rest (caar as)) 101 `(let ((,(cdar as) ,(walk `(%list ,@args) e #f (car vars)))) 102 ,(loop '() '() '()))) 103 ((null? args) 104 `(let ((,(cdar as) (%void))) 105 ,(loop (cdr as) (cdr vars) '()))) 106 (else 107 `(let ((,(cdar as) ,(walk (car args) e #f (car vars)))) 108 ,(loop (cdr as) (cdr vars) (cdr args))))))))) 109 (('lambda _ ('%dispatch lambdas ...)) 110 (walk (last lambdas) e tail ldest)) 111 (('letrec () body ...) 112 (walk `(begin ,@body) e tail ldest)) 113 (('letrec ((vars vals) ...) body ...) 114 (let* ((aliases (map (lambda (v) (cons v (temp))) vars)) 115 (e2 (append aliases e))) 116 (let loop1 ((as aliases)) 117 (if (null? as) 118 (if strict-mode 119 (let ((temps (map (lambda _ (temp)) aliases))) 120 (let loop2 ((tmps temps) (vals vals)) 121 (if (null? tmps) 122 (let loop3 ((as aliases) (temps temps)) 123 (if (null? as) 124 (walk `(begin ,@body) e2 tail #f) 125 `(let ((%unused (set! ,(cdar as) ,(car temps)))) 126 ,(loop3 (cdr as) (cdr temps))))) 127 `(let ((,(car tmps) ,(walk (car vals) e2 #f #f))) 128 ,(loop2 (cdr tmps) (cdr vals)))))) 129 (let loop2 ((as aliases) (vars vars) (vals vals)) 130 (if (null? as) 131 (walk `(begin ,@body) e2 tail #f) 132 `(let ((%unused 133 (set! ,(cdar as) ,(walk (car vals) e2 #f (car vars))))) 134 ,(loop2 (cdr as) (cdr vars) (cdr vals)))))) 135 `(let ((,(cdar as) (%void))) 136 ,(loop1 (cdr as))))))) 137 (('%check type x) 138 (if (not debug-mode) 139 (walk x e tail ldest) 140 `(%check ,type ,(walk x e tail ldest)))) 141 (('%check x) 142 (if (not debug-mode) 143 ''#t 144 (walk x e tail ldest))) 145 (((or '%void '%void?) args ...) 146 `(,(car x) ,@(map (cut walk <> e #f #f) args))) 147 (('%host-ref (or ('quote name) name)) 148 `(%host-ref ,(normalize-ref name))) 149 (('%host-set! (or ('quote name) name) x) 150 `(%host-set! ,(normalize-ref name) ,(walk x e #f #f))) 151 (('%syntax-error msg . arg) 152 (apply fail msg arg)) 153 (('%new args ...) 154 `(%new ,@(map (cut walk <> e #f #f) args))) 155 (('%property-ref (or ('quote name) name) x) 156 `(%property-ref ,(normalize-ref name) ,(walk x e #f #f))) 157 (('%property-ref (or ('quote name) name)) 158 `(%property-ref ,(normalize-ref name))) 159 (('%property-set! (or ('quote name) name) x y) 160 `(%property-set! 161 ,(normalize-ref name) 162 ,(walk x e #f #f) 163 ,(walk y e #f #f))) 164 (('%inline (or name ('quote name)) xs ...) 165 `(%inline ,name ,@(map (cut walk <> e #f #f) xs))) 166 (((or '%native-lambda '%code) code ...) x) 167 (('begin x) (walk x e tail ldest)) 168 (('begin) '(%void)) 169 (('begin x1 . more) 170 `(let ((%unused ,(walk x1 e #f #f))) 171 ,(walk `(begin ,@more) e tail ldest))) 172 (('lambda llist body ...) 173 (set! looping #f) 174 (match-let (((vars rest) (parse-llist llist))) 175 (let* ((aliases (map (lambda (v) (cons v (temp))) vars)) 176 (newllist 177 (append 178 (map cdr (if rest (butlast aliases) aliases)) 179 (if rest 180 (cdr (assq rest aliases)) 181 '())))) 182 `(lambda ,newllist 183 ,(fluid-let ((looping #t)) 184 ;; walking body checks for self-call in tail-pos. and sets `looping' 185 (let ((body (walk `(begin ,@body) (append aliases e) #t ldest))) 186 (if looping 187 `(%loop ,newllist ,body) 188 body))))))) 189 (('define v x) 190 (when (and xref-mode 191 (not (get v 'defined))) 192 (put! v 'defined #t) 193 (set! defined (cons v defined))) 194 `(%global-set! ,v ,(walk x e #f #f))) 195 ;;XXX we actually have to check `op' for not being a special form name 196 ((op args ...) 197 (cond ((and tail (symbol? op) (eq? op ldest)) ; tail + self call? 198 `(%continue ,@(map (cut walk <> e #f #f) x))) 199 (else 200 (set! looping #f) 201 (map (cut walk <> e #f #f) x)))) 202 (_ (fail "bad expression" x)))) 203 (walk form '() #t #f))) 204 205 ;; CPS-conversion algorithm from "Essentials of Programming Languages" 206 (define (cps form) 207 (let ((toplambdas '())) 208 (define (zero x) 209 (let ((k (temp "k"))) 210 `(lambda (,k) ,(one x k)))) ; Cpgm 211 (define (one x k) 212 (match x 213 (('let ((v x)) y) ; canonicalizer only generates single-var `let' 214 (if (simple? x) 215 `(let ((,v ,(two x))) ; Clet 216 ,(one y k)) 217 (let ((t (temp))) ; Chead 218 (one x `(lambda (,t) 219 (let ((,v ,t)) 220 ,(one y k))))))) 221 ((? simple?) 222 (callk k (lambda () x))) 223 ;; from here on `x' is non-simple 224 (((or 'set! '%global-set! '%host-set!) v y) 225 (let ((t (temp))) 226 (one y `(lambda (,t) ; Chead 227 (let ((%unused (,(car x) ,v ,t))) 228 ,(callk k (lambda () '(%void)))))))) 229 (('if x y z) 230 (bindk 231 k 232 (lambda (k) ; Cif 233 (if (simple? x) 234 `(if ,(two x) 235 ,(one y k) 236 ,(one z k)) 237 (let ((t (temp))) ; Chead 238 (one x `(lambda (,t) 239 (if ,t 240 ,(one y k) 241 ,(one z k))))))))) 242 (('%loop llist x) `(%loop ,llist ,(one x k))) 243 (('%continue args ...) 244 (head 245 args 246 (lambda (args2) 247 `(%continue ,(car args2) ,k ,@(cdr args2))))) 248 (((or '%property-set! '%inline) info xs ...) 249 ;; simple %inline/%property-set! form is already handled above 250 (head 251 xs 252 (lambda (xs2) 253 (callk k (lambda () `(,(car x) ,info ,@xs2)))))) 254 (('%check type x) ; s.a. 255 (head 256 (list x) 257 (lambda (xs2) 258 (callk k (lambda () `(%check ,type ,@xs2)))))) 259 (('%new args ...) 260 (head 261 args 262 (lambda (args2) 263 (callk k (lambda () `(%new ,@args2)))))) 264 (((? simple?) ...) ; Capp 265 (cons (two (car x)) (cons k (map two (cdr x))))) 266 ((xs ...) 267 (head 268 xs 269 (lambda (xs2) (cons (car xs2) (cons k (cdr xs2)))))) 270 (else (error "one" x k)))) 271 (define (two x) 272 (match x 273 ((? symbol?) x) 274 (('lambda llist body) ; Cproc 275 (let ((k (temp "k"))) 276 `(lambda (,k . ,llist) ,(one body k)))) 277 (('if xs ...) `(if ,@(map two xs))) 278 (((or '%inline '%property-set!) info xs ...) 279 `(,(car x) ,info ,@(map two xs))) 280 (((or 'set! '%global-set! '%check) v y) `(,(car x) ,v ,(two y))) 281 (((or 'quote '%host-ref '%code '%native-lambda '%void) . _) x) 282 (('%property-ref parts) x) 283 (((or '%host-set! '%property-ref) parts y) 284 `(,(car x) ,parts ,(two y))) 285 (('let ((var x)) y) 286 `(let ((,var ,(two x))) ,(two y))) 287 (((or '%new '%continue '%void?) xs ...) `(,(car x) ,@(map two xs))) 288 ((xs ...) (map two xs)) 289 (_ (error "two" x)))) 290 (define (bindk k proc) 291 (if (symbol? k) 292 (proc k) 293 (let ((t (temp))) 294 `(let ((,t ,k)) 295 ,(proc t))))) 296 (define (callk k thunk) 297 (if (symbol? k) 298 `(,k ,(two (thunk))) ; Csimplevar 299 (let ((v (caadr k))) ; Csimpleproc 300 `(let ((,v ,(two (thunk)))) ;XXX must we `two' here as well? 301 ,(caddr k))))) 302 (define (head xs wrap) 303 (let loop ((xs xs) (xs2 '())) ; Chead 304 (if (null? xs) 305 (wrap (reverse xs2)) 306 (let ((x (car xs))) 307 (if (simple? x) 308 (loop (cdr xs) (cons (two x) xs2)) 309 (let ((t (temp))) 310 (one x `(lambda (,t) 311 ,(loop (cdr xs) (cons t xs2)))))))))) 312 (define (simple? x) 313 (match x 314 (((or '%host-ref '%code 'lambda 'quote '%global-ref '%void 315 '%native-lambda) . _) 316 #t) 317 (('%property-ref _) #t) 318 (((or '%host-set! '%property-ref) _ x) (simple? x)) 319 ((? symbol?) #t) 320 (('if (? simple?) ...) #t) 321 (('%void? (? simple?)) #t) 322 (('let ((_ (? simple?))) (? simple?)) #t) 323 (((or 'set! '%inline '%global-set! '%check '%new '%property-set!) _ (? simple?) ...) 324 #t) 325 (((or '%loop '%continue) . _) #f) 326 (_ #f))) 327 (define (sequence parts) 328 (let loop ((parts parts)) 329 (if (null? (cdr parts)) 330 (car parts) 331 `(let (,(car parts)) 332 ,(loop (cdr parts)))))) 333 (define (toplambda parts) 334 (set! toplambdas (cons (zero (sequence parts)) toplambdas))) 335 (define (top x parts) 336 ;; perform "clustering": build groups of toplevel forms 337 ;; transformed together to reduce function nesting 338 ;; XXX is this still needed, or does this pay off? 339 (match x 340 (('let ((_ (? simple?))) y) 341 (top y (cons (caadr x) parts))) 342 (('let (('%unused z)) y) 343 (toplambda (reverse (cons z parts))) 344 (top y '())) 345 (_ (toplambda 346 (if (null? parts) 347 (list x) 348 (reverse (cons x parts))))))) 349 (top form '()) 350 (reverse toplambdas)))