smalltalk-tng

annotate experiments/partial-eval/pe.scm @ 321:c4a0718c2d3c

find changesets by author, revision, files, or words in the commit message
Sketch of dependencies
author Tony Garnock-Jones <tonygarnockjones@gmail.com>
date Sat Oct 08 15:36:03 2011 -0400 (7 months ago)
parents 2ab69289317c
children
rev   line source
tonyg@24 1 ;; Similar to the partial-evaluator in "Partial Evaluator as a
tonyg@24 2 ;; Compiler for Reflective Languages", Asai, Masuhara, Matsuoka and
tonyg@24 3 ;; Yonezawa (1995), but without preactions (yet).
tonyg@24 4 ;;
tonyg@24 5 ;; Copyright (C) 2005 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
tonyg@24 6
tonyg@159 7 (require (lib "1.ss" "srfi") (lib "9.ss" "srfi") (lib "pretty.ss"))
tonyg@159 8 ;;(require 'srfi-1)
tonyg@24 9
tonyg@24 10 (define (make-node kind . vals0)
tonyg@24 11 (let walk ((vals vals0)
tonyg@24 12 (acc '()))
tonyg@24 13 (cond
tonyg@24 14 ((null? vals) (cons kind (reverse acc)))
tonyg@24 15 ((null? (cdr vals)) (error "Bad arg list to make-node" (cons kind vals0)))
tonyg@24 16 (else (walk (cddr vals)
tonyg@24 17 (cons (list (car vals) (cadr vals)) acc))))))
tonyg@24 18
tonyg@24 19 (define (node-kind node) (car node))
tonyg@24 20
tonyg@24 21 (define (node-ref node field)
tonyg@24 22 (cond
tonyg@24 23 ((assq field (cdr node)) => cadr)
tonyg@24 24 (else (error "No such field in node" (list field node)))))
tonyg@24 25
tonyg@24 26 (define (node-kind? node kind)
tonyg@24 27 (eq? (node-kind node) kind))
tonyg@24 28
tonyg@24 29 (define (make-lit val)
tonyg@24 30 (make-node 'lit 'val val))
tonyg@24 31
tonyg@24 32 (define (lit-value node)
tonyg@24 33 (node-ref node 'val))
tonyg@24 34
tonyg@24 35 (define (lit? node)
tonyg@24 36 (node-kind? node 'lit))
tonyg@24 37
tonyg@24 38 (define (make-undefined)
tonyg@24 39 (make-lit 'UNDEF))
tonyg@24 40
tonyg@24 41 (define (parse-let is-rec exp env)
tonyg@24 42 (let ((names (map car (cadr exp)))
tonyg@24 43 (inits (map cadr (cadr exp)))
tonyg@24 44 (bodyexp `(begin ,@(cddr exp))))
tonyg@24 45 (cond
tonyg@24 46 ((null? names) (parse bodyexp env))
tonyg@24 47 (is-rec (let* ((new-env (append names env))
tonyg@24 48 (p (lambda (x) (parse x new-env))))
tonyg@24 49 (make-node 'letrec
tonyg@24 50 'names names
tonyg@24 51 'inits (map p inits)
tonyg@24 52 'body (p bodyexp))))
tonyg@24 53 (else (parse `((lambda ,names (filter 'unfold) ,bodyexp) ,@inits) env)))))
tonyg@24 54
tonyg@24 55 (define (parse exp env)
tonyg@24 56 (let walk ((exp exp))
tonyg@24 57 (cond
tonyg@24 58 ((symbol? exp) (make-node 'ref 'name exp))
tonyg@24 59 ((not (pair? exp)) (make-lit exp))
tonyg@24 60 (else
tonyg@24 61 (case (car exp)
tonyg@24 62 ((quote) (make-lit (cadr exp)))
tonyg@167 63 ((lambda) (let* ((has-filter (and (pair? (caddr exp))
tonyg@167 64 (eq? (car (caddr exp)) 'filter)))
tonyg@24 65 (formals (cadr exp))
tonyg@24 66 (filter (and has-filter (cadr (caddr exp))))
tonyg@24 67 (body (if has-filter (cdddr exp) (cddr exp)))
tonyg@24 68 (newenv (append formals env)))
tonyg@24 69 (make-node 'lambda
tonyg@24 70 'formals formals
tonyg@24 71 'filter (and filter (parse filter newenv))
tonyg@24 72 'body (parse `(begin ,@body) newenv))))
tonyg@168 73 ((lambda*) (parse `(lambda ,(cadr exp)
tonyg@168 74 (filter 'unfold)
tonyg@168 75 ,@(cddr exp)) env))
tonyg@24 76 ((begin) (cond
tonyg@24 77 ((null? (cdr exp)) (make-undefined))
tonyg@24 78 ((null? (cddr exp)) (walk (cadr exp)))
tonyg@24 79 (else (make-node 'begin 'exprs (map walk (cdr exp))))))
tonyg@24 80 ((if) (make-node 'if
tonyg@24 81 'test (walk (cadr exp))
tonyg@24 82 'true (walk (caddr exp))
tonyg@24 83 'false (if (null? (cdddr exp))
tonyg@24 84 (make-undefined)
tonyg@24 85 (walk (car (cdddr exp))))))
tonyg@169 86 ((cond) (if (eq? (car (cadr exp)) 'else)
tonyg@169 87 (parse `(begin ,@(cdr (cadr exp))) env)
tonyg@169 88 (parse `(if ,(car (cadr exp))
tonyg@169 89 (begin ,@(cdr (cadr exp)))
tonyg@169 90 (cond ,@(cddr exp))) env)))
tonyg@24 91 ((let) (if (symbol? (cadr exp))
tonyg@24 92 (walk `(letrec ((,(cadr exp) (lambda ,(map car (caddr exp))
tonyg@24 93 ,@(cdddr exp))))
tonyg@24 94 (,(cadr exp) ,@(map cadr (caddr exp)))))
tonyg@24 95 (parse-let #f exp env)))
tonyg@24 96 ((letrec) (parse-let #t exp env))
tonyg@24 97 ((let*) (if (null? (cadr exp))
tonyg@24 98 (walk `(begin ,@(cddr exp)))
tonyg@24 99 (walk `(let (,(caadr exp)) (let* ,(cdadr exp) ,@(cddr exp))))))
tonyg@24 100 (else (make-node 'apply
tonyg@24 101 'rator (walk (car exp))
tonyg@24 102 'rands (map walk (cdr exp)))))))))
tonyg@24 103
tonyg@24 104 (define (extend-env env names inits)
tonyg@24 105 (append (if inits
tonyg@24 106 (map (lambda (name init)
tonygarnockjones@300 107 (cons name (box (list init))))
tonyg@24 108 names inits)
tonyg@24 109 (map (lambda (name)
tonygarnockjones@300 110 (cons name (box #f)))
tonyg@24 111 names))
tonyg@24 112 env))
tonyg@24 113
tonyg@24 114 (define (sval-known? node)
tonyg@24 115 (memq (node-kind node) '(lit cons prim closure)))
tonyg@24 116
tonyg@24 117 (define (WARN message . args)
tonyg@24 118 (display ";; ")
tonyg@24 119 (display message)
tonyg@24 120 (for-each (lambda (x)
tonyg@24 121 (display " ")
tonyg@24 122 (display x))
tonyg@24 123 args)
tonyg@24 124 (newline))
tonyg@24 125
tonyg@24 126 (define (pe pexp env cache)
tonyg@24 127 ;;(pretty-print `(pe (pexp ,pexp) ));; (env ,env) (cache ,cache)))
tonyg@24 128 (case (node-kind pexp)
tonyg@24 129 ((lit) pexp)
tonyg@24 130 ((letrec) (let ((newenv (extend-env env (node-ref pexp 'names) #f)))
tonyg@24 131 (for-each (lambda (name init)
tonyg@24 132 (let ((binding (assq name newenv)))
tonygarnockjones@300 133 (set-box! (cdr binding) (list (pe init newenv cache)))))
tonyg@24 134 (node-ref pexp 'names)
tonyg@24 135 (node-ref pexp 'inits))
tonyg@24 136 ;; BUG: need to collect free variables of the pe'd body,
tonyg@24 137 ;; and if there are references to any of this pexp's names,
tonyg@24 138 ;; we need to wrap the pe'd body in a letrec of the relevant
tonyg@24 139 ;; names. (Actually, iterate until we've pulled in everything
tonyg@24 140 ;; we need.)
tonyg@24 141 (pe (node-ref pexp 'body) newenv cache)))
tonyg@24 142 ((ref) (let* ((name (node-ref pexp 'name))
tonyg@24 143 (binding (assq name env)))
tonyg@24 144 (cond
tonyg@24 145 ((not binding) pexp)
tonygarnockjones@300 146 ((not (unbox (cdr binding))) pexp)
tonygarnockjones@300 147 (else (car (unbox (cdr binding)))))))
tonyg@24 148 ((lambda) (make-node 'closure
tonyg@24 149 'formals (node-ref pexp 'formals)
tonyg@24 150 'filter (node-ref pexp 'filter)
tonyg@24 151 'body (node-ref pexp 'body)
tonyg@24 152 'env env))
tonyg@24 153 ((begin) (begin
tonyg@24 154 (for-each (lambda (exp) (WARN ";; Ignoring" exp))
tonyg@24 155 (drop-right (node-ref pexp 'exprs) 1))
tonyg@24 156 (pe (car (take-right (node-ref pexp 'exprs) 1)) env cache)))
tonyg@24 157 ((if) (let ((val (pe (node-ref pexp 'test) env cache)))
tonyg@24 158 (if (sval-known? val)
tonyg@24 159 (if (and (lit? val)
tonyg@24 160 (lit-value val))
tonyg@24 161 (pe (node-ref pexp 'true) env cache)
tonyg@24 162 (pe (node-ref pexp 'false) env cache))
tonyg@24 163 (make-node 'if
tonyg@24 164 'test val
tonyg@24 165 'true (pe (node-ref pexp 'true) env cache)
tonyg@24 166 'false (pe (node-ref pexp 'false) env cache)))))
tonyg@24 167 ((apply) (let* ((rator (pe (node-ref pexp 'rator) env cache))
tonyg@24 168 (rands (map (lambda (x) (pe x env cache)) (node-ref pexp 'rands))))
tonyg@24 169 (if (sval-known? rator)
tonyg@24 170 (case (node-kind rator)
tonyg@24 171 ((closure)
tonyg@24 172 (let* ((filter (node-ref rator 'filter))
tonyg@24 173 (formals (node-ref rator 'formals))
tonyg@24 174 (rator-env (node-ref rator 'env))
tonyg@24 175 (newenv (extend-env rator-env formals rands))
tonyg@24 176 (directive (if (not filter)
tonyg@24 177 (if (every sval-known? rands)
tonyg@24 178 'unfold
tonyg@24 179 (map (lambda (formal) #f) formals))
tonyg@24 180 (let ((v (pe filter newenv cache)))
tonyg@24 181 (if (not (lit? v))
tonyg@24 182 (error "Bad filter" (codegen filter))
tonyg@24 183 (lit-value v))))))
tonyg@24 184 (cond
tonyg@24 185 ((eq? directive 'unfold)
tonyg@24 186 (pe (node-ref rator 'body)
tonyg@24 187 newenv
tonyg@24 188 cache))
tonyg@24 189 ((and (list? directive)
tonyg@24 190 (every boolean? directive))
tonyg@24 191 (let* ((prop-rands (map (lambda (prop formal rand)
tonyg@24 192 (if prop
tonyg@24 193 rand
tonyg@24 194 (make-node 'ref 'name formal)))
tonyg@24 195 directive
tonyg@24 196 formals
tonyg@24 197 rands))
tonyg@24 198 (cache-key (cons rator prop-rands))
tonyg@24 199 (cache-entry (assoc cache-key cache)))
tonyg@24 200 (if cache-entry
tonyg@24 201 (make-node 'apply-cached
tonyg@24 202 'rator (cadr cache-entry)
tonyg@24 203 'rands rands)
tonyg@24 204 (let* ((tmp-sym (gensym))
tonyg@24 205 (tmp (make-node 'ref 'name tmp-sym))
tonyg@24 206 (lambda-node
tonyg@24 207 (make-node 'closure
tonyg@24 208 'formals formals
tonyg@24 209 'filter (node-ref rator 'filter)
tonyg@24 210 'body (pe (node-ref rator 'body)
tonyg@24 211 (extend-env rator-env
tonyg@24 212 formals prop-rands)
tonyg@24 213 (cons (list cache-key tmp)
tonyg@24 214 cache))
tonyg@24 215 'env rator-env)))
tonyg@24 216 (make-node 'letrec
tonyg@24 217 'names (list tmp-sym)
tonyg@24 218 'inits (list lambda-node)
tonyg@24 219 'body (make-node 'apply
tonyg@24 220 'rator tmp
tonyg@24 221 'rands rands))))))
tonyg@24 222 (else (error "Bad filter result" directive)))))
tonyg@24 223 ((prim)
tonyg@24 224 ;;(pretty-print `(prim ,(node-ref rator 'prim-name) ));; ,@rands))
tonyg@24 225 (apply (node-ref rator 'handler) rands))
tonyg@24 226 (else (error "Bad node kind in rator in apply" (list pexp rator))))
tonyg@24 227 (make-node 'apply
tonyg@24 228 'rator rator
tonyg@24 229 'rands rands))))
tonyg@24 230 (else (error "Bad node kind in pe" pexp))))
tonyg@24 231
tonyg@173 232 (define (codegen0 pexp)
tonyg@24 233 (case (node-kind pexp)
tonyg@24 234 ((lit) `(quote ,(node-ref pexp 'val)))
tonyg@172 235 ((cons) (let ((acode (codegen (node-ref pexp 'a)))
tonyg@172 236 (d (node-ref pexp 'd)))
tonyg@172 237 (if (and (lit? d)
tonyg@172 238 (eq? (lit-value d) '()))
tonyg@172 239 `(LIST ,acode)
tonyg@172 240 (let ((dcode (codegen d)))
tonyg@172 241 (if (and (pair? dcode)
tonyg@172 242 (eq? (car dcode) 'LIST))
tonyg@172 243 `(LIST ,acode ,@(cdr dcode))
tonyg@172 244 `(cons ,acode ,dcode))))))
tonyg@24 245 ((prim) (node-ref pexp 'prim-name))
tonyg@24 246 ((closure) `(lambda ,(node-ref pexp 'formals)
tonyg@24 247 ,@(if (node-ref pexp 'filter)
tonyg@24 248 `((filter ,(codegen (node-ref pexp 'filter))))
tonyg@24 249 '())
tonyg@24 250 ,(codegen (node-ref pexp 'body))))
tonyg@24 251
tonyg@24 252 ((letrec) `(letrec ,(map list
tonyg@24 253 (node-ref pexp 'names)
tonyg@24 254 (map codegen (node-ref pexp 'inits)))
tonyg@24 255 ,(codegen (node-ref pexp 'body))))
tonyg@24 256 ((ref) (node-ref pexp 'name))
tonyg@24 257 ((lambda) `(lambda ,(node-ref pexp 'formals)
tonyg@24 258 ,@(if (node-ref pexp 'filter)
tonyg@24 259 `((filter ,(codegen (node-ref pexp 'filter))))
tonyg@24 260 '())
tonyg@24 261 ,(codegen (node-ref pexp 'body))))
tonyg@24 262 ((begin) `(begin ,@(map codegen (node-ref pexp 'exprs))))
tonyg@24 263 ((if) `(if ,(codegen (node-ref pexp 'test))
tonyg@24 264 ,(codegen (node-ref pexp 'true))
tonyg@24 265 ,(codegen (node-ref pexp 'false))))
tonyg@24 266 ((apply) `(,(codegen (node-ref pexp 'rator)) ,@(map codegen (node-ref pexp 'rands))))
tonyg@24 267 ((apply-cached) `(GOTO ,(codegen (node-ref pexp 'rator))
tonyg@24 268 ,@(map codegen (node-ref pexp 'rands))))
tonyg@24 269 (else (error "Bad node-kind in codegen" pexp))))
tonyg@24 270
tonyg@173 271 (define (free-names pexp)
tonyg@173 272 (case (node-kind pexp)
tonyg@173 273 ((lit) '())
tonyg@173 274 ((cons) (lset-union eq?
tonyg@173 275 (free-names (node-ref pexp 'a))
tonyg@173 276 (free-names (node-ref pexp 'd))))
tonyg@173 277 ((prim) '())
tonyg@173 278 ((closure lambda) (lset-difference eq?
tonyg@173 279 (free-names (node-ref pexp 'body))
tonyg@173 280 (node-ref pexp 'formals)))
tonyg@173 281 ((letrec) (lset-difference eq?
tonyg@173 282 (apply lset-union eq?
tonyg@173 283 (free-names (node-ref pexp 'body))
tonyg@173 284 (map free-names (node-ref pexp 'inits)))
tonyg@173 285 (node-ref pexp 'names)))
tonyg@173 286 ((ref) (list (node-ref pexp 'name)))
tonyg@173 287 ((begin) (apply lset-union eq? (map free-names (node-ref pexp 'exprs))))
tonyg@173 288 ((if) (lset-union eq?
tonyg@173 289 (free-names (node-ref pexp 'test))
tonyg@173 290 (free-names (node-ref pexp 'true))
tonyg@173 291 (free-names (node-ref pexp 'false))))
tonyg@173 292 ((apply apply-cached) (apply lset-union eq?
tonyg@173 293 (free-names (node-ref pexp 'rator))
tonyg@173 294 (map free-names (node-ref pexp 'rands))))
tonyg@173 295 (else (error "Bad node-kind in free-names" pexp))))
tonyg@173 296
tonyg@173 297 (define (codegen pexp)
tonygarnockjones@300 298 (let ((cache (box '()))) ;; alist of (pexp use-count-box temp-var-sym reduced-expr-box)
tonyg@173 299 (define (walk pexp)
tonyg@173 300 (cond
tonygarnockjones@300 301 ((assq pexp (unbox cache)) =>
tonyg@173 302 (lambda (entry)
tonygarnockjones@300 303 (set-box! (cadr entry) (+ (unbox (cadr entry)) 1))
tonyg@173 304 (caddr entry)))
tonyg@173 305 (else
tonygarnockjones@300 306 (let ((entry (list pexp (box 1) (gensym 't) (box #f))))
tonygarnockjones@300 307 (set-box! cache (cons entry (unbox cache)))
tonyg@173 308 (let ((exp (walk1 pexp)))
tonygarnockjones@300 309 (set-box! (car (cdddr entry)) exp)
tonyg@173 310 (caddr entry))))))
tonyg@173 311 (define (env-entry-walker names)
tonyg@173 312 (lambda (entry)
tonyg@173 313 (if (memq (car entry) names)
tonygarnockjones@300 314 (list (list (car entry) (walk (car (unbox (cdr entry))))))
tonyg@173 315 '())))
tonyg@173 316 (define (walk1 pexp)
tonyg@173 317 (case (node-kind pexp)
tonyg@173 318 ((lit) `(quote ,(node-ref pexp 'val)))
tonyg@173 319 ((cons) (let ((acode (walk (node-ref pexp 'a)))
tonyg@173 320 (d (node-ref pexp 'd)))
tonyg@173 321 (if (and (lit? d)
tonyg@173 322 (eq? (lit-value d) '()))
tonyg@173 323 `(LIST ,acode)
tonyg@173 324 (let ((dcode (walk d)))
tonyg@173 325 (if (and (pair? dcode)
tonyg@173 326 (eq? (car dcode) 'LIST))
tonyg@173 327 `(LIST ,acode ,@(cdr dcode))
tonyg@173 328 `(cons ,acode ,dcode))))))
tonyg@173 329 ((prim) (node-ref pexp 'prim-name))
tonyg@173 330 ((closure) `(let (,@(append-map (env-entry-walker (free-names (node-ref pexp 'body)))
tonyg@173 331 (node-ref pexp 'env)))
tonyg@173 332 (lambda ,(node-ref pexp 'formals)
tonyg@173 333 ,@(if (node-ref pexp 'filter)
tonyg@173 334 `((filter ,(walk (node-ref pexp 'filter))))
tonyg@173 335 '())
tonyg@173 336 ,(walk (node-ref pexp 'body)))))
tonyg@173 337 ((letrec) `(letrec ,(map list
tonyg@173 338 (node-ref pexp 'names)
tonyg@173 339 (map walk (node-ref pexp 'inits)))
tonyg@173 340 ,(walk (node-ref pexp 'body))))
tonyg@173 341 ((ref) (node-ref pexp 'name))
tonyg@173 342 ((lambda) `(lambda ,(node-ref pexp 'formals)
tonyg@173 343 ,@(if (node-ref pexp 'filter)
tonyg@173 344 `((filter ,(walk (node-ref pexp 'filter))))
tonyg@173 345 '())
tonyg@173 346 ,(walk (node-ref pexp 'body))))
tonyg@173 347 ((begin) `(begin ,@(map walk (node-ref pexp 'exprs))))
tonyg@173 348 ((if) `(if ,(walk (node-ref pexp 'test))
tonyg@173 349 ,(walk (node-ref pexp 'true))
tonyg@173 350 ,(walk (node-ref pexp 'false))))
tonyg@173 351 ((apply) `(,(walk (node-ref pexp 'rator)) ,@(map walk (node-ref pexp 'rands))))
tonyg@173 352 ((apply-cached) `(GOTO ,(walk (node-ref pexp 'rator))
tonyg@173 353 ,@(map walk (node-ref pexp 'rands))))
tonyg@173 354 (else (error "Bad node-kind in codegen" pexp))))
tonyg@173 355 (let* ((exp (walk pexp))
tonyg@173 356 (remapped-cache (map (lambda (entry)
tonygarnockjones@300 357 (list (caddr entry) ;; temp-var-sym
tonygarnockjones@300 358 (unbox (cadr entry)) ;; use-count
tonygarnockjones@300 359 (unbox (cadddr entry)))) ;; reduced-expr
tonygarnockjones@300 360 (unbox cache))))
tonyg@173 361 (define (inlinable? entry)
tonyg@173 362 (or (= (cadr entry) 1)
tonyg@173 363 (let ((v (caddr entry)))
tonyg@173 364 (or (symbol? v)
tonyg@173 365 (and (pair? v)
tonyg@173 366 (pair? (cdr v))
tonyg@173 367 (null? (cddr v))
tonyg@173 368 (eq? (car v) 'quote)
tonyg@173 369 (symbol? (cadr v)))))))
tonyg@173 370 (define (inline exp)
tonyg@173 371 (cond
tonyg@173 372 ((pair? exp) (cons (inline (car exp)) (inline (cdr exp))))
tonyg@173 373 ((assq exp remapped-cache) =>
tonyg@173 374 (lambda (entry)
tonyg@173 375 (if (inlinable? entry)
tonyg@173 376 (inline (caddr entry))
tonyg@173 377 exp)))
tonyg@173 378 (else exp)))
tonyg@173 379 (let ((filtered-mapped-cache (map (lambda (entry)
tonyg@173 380 (list (car entry) (cadr entry) (inline (caddr entry))))
tonyg@173 381 (filter (lambda (entry) (not (inlinable? entry)))
tonyg@173 382 remapped-cache))))
tonyg@173 383 `(codegen-result ,(inline exp) ,filtered-mapped-cache)))))
tonyg@173 384
tonyg@24 385 (define (residualize-apply name . args)
tonyg@24 386 (make-node 'apply 'rator (make-node 'ref 'name name) 'rands args))
tonyg@24 387
tonyg@24 388 (define (prim-env)
tonyg@24 389 (map (lambda (entry)
tonygarnockjones@300 390 (cons (car entry)
tonygarnockjones@300 391 (box (list (make-node 'prim
tonygarnockjones@300 392 'prim-name (car entry)
tonygarnockjones@300 393 'handler (cadr entry))))))
tonyg@24 394 (list
tonyg@24 395 (list 'sval-known? (lambda (x)
tonyg@24 396 (make-lit (sval-known? x))))
tonyg@24 397 (list '+ (lambda vals
tonyg@24 398 (call-with-values (lambda () (partition sval-known? vals))
tonyg@24 399 (lambda (known unknown)
tonyg@24 400 (let* ((part-val (apply + (map lit-value known)))
tonyg@24 401 (part (make-lit part-val)))
tonyg@24 402 (cond
tonyg@24 403 ((null? unknown) part)
tonyg@24 404 ((zero? part-val) (apply residualize-apply '+ unknown))
tonyg@24 405 (else (apply residualize-apply '+ part unknown))))))))
tonyg@24 406 (list '- (lambda (a b)
tonyg@24 407 (if (and (sval-known? a) (sval-known? b))
tonyg@24 408 (make-lit (- (lit-value a) (lit-value b)))
tonyg@24 409 (residualize-apply '- a b))))
tonyg@24 410 (list '< (lambda (a b)
tonyg@24 411 (if (and (sval-known? a) (sval-known? b))
tonyg@24 412 (make-lit (< (lit-value a) (lit-value b)))
tonyg@24 413 (residualize-apply '< a b))))
tonyg@24 414 (list 'cons (lambda (a d) (make-node 'cons 'a a 'd d)))
tonyg@24 415 (list 'null? (lambda (x)
tonyg@24 416 (if (sval-known? x)
tonyg@24 417 (make-lit (and (lit? x)
tonyg@24 418 (null? (lit-value x))))
tonyg@24 419 (residualize-apply 'null? x))))
tonyg@24 420 (list 'pair? (lambda (x)
tonyg@24 421 (if (sval-known? x)
tonyg@24 422 (make-lit (or (node-kind? x 'cons)
tonyg@24 423 (and (lit? x)
tonyg@24 424 (pair? (lit-value x)))))
tonyg@24 425 (residualize-apply 'pair? x))))
tonyg@24 426 (list 'zero? (lambda (x)
tonyg@24 427 (if (sval-known? x)
tonyg@24 428 (make-lit (zero? (lit-value x)))
tonyg@24 429 (residualize-apply 'zero? x))))
tonyg@174 430 (list 'eq? (lambda (x y)
tonyg@174 431 (if (and (lit? x)
tonyg@174 432 (lit? y))
tonyg@174 433 (make-lit (eq? (lit-value x) (lit-value y)))
tonyg@174 434 (residualize-apply 'eq? x y))))
tonyg@24 435 (list 'PRIMcar (lambda (x)
tonyg@24 436 (if (sval-known? x)
tonyg@24 437 (cond
tonyg@24 438 ((node-kind? x 'cons) (node-ref x 'a))
tonyg@24 439 ((and (lit? x) (pair? (lit-value x))) (make-lit (car (lit-value x))))
tonyg@24 440 (else (residualize-apply 'PRIMcar x)))
tonyg@24 441 (residualize-apply 'PRIMcar x))))
tonyg@24 442 (list 'PRIMcdr (lambda (x)
tonyg@24 443 (if (sval-known? x)
tonyg@24 444 (cond
tonyg@24 445 ((node-kind? x 'cons) (node-ref x 'd))
tonyg@24 446 ((and (lit? x) (pair? (lit-value x))) (make-lit (cdr (lit-value x))))
tonyg@24 447 (else (residualize-apply 'PRIMcdr x)))
tonyg@24 448 (residualize-apply 'PRIMcdr x)))))))
tonyg@24 449
tonyg@24 450 (define (basic-env)
tonyg@24 451 (fold (lambda (entry env)
tonygarnockjones@300 452 (cons (cons (car entry)
tonygarnockjones@300 453 (box (list (pe (parse (cadr entry) '()) env '()))))
tonyg@24 454 env))
tonyg@24 455 (prim-env)
tonyg@24 456 (list
tonyg@24 457 (list 'car '(lambda (x)
tonyg@24 458 (filter 'unfold)
tonyg@24 459 (if (pair? x)
tonyg@24 460 (PRIMcar x)
tonyg@24 461 (error "Not a pair in car" x))))
tonyg@24 462 (list 'cdr '(lambda (x)
tonyg@24 463 (filter 'unfold)
tonyg@24 464 (if (pair? x)
tonyg@24 465 (PRIMcdr x)
tonyg@24 466 (error "Not a pair in cdr" x))))
tonyg@24 467 ; (list 'car 'PRIMcar)
tonyg@24 468 ; (list 'cdr 'PRIMcdr)
tonyg@24 469 (list 'reverse '(lambda (x)
tonyg@24 470 (filter 'unfold)
tonyg@24 471 (let loop ((x x) (acc '()))
tonyg@24 472 (if (null? x)
tonyg@24 473 acc
tonyg@24 474 (loop (cdr x) (cons (car x) acc))))))
tonyg@24 475 (list 'fold '(lambda (f acc x)
tonyg@24 476 (filter (if (sval-known? f) 'unfold '(#f #f #f)))
tonyg@24 477 (let loop ((x x) (acc acc))
tonyg@24 478 (if (null? x)
tonyg@24 479 acc
tonyg@24 480 (loop (cdr x) (f (car x) acc))))))
tonyg@24 481 (list 'fold-right '(lambda (f acc x)
tonyg@24 482 (filter (if (sval-known? f) 'unfold '(#f #f #f)))
tonyg@24 483 (let loop ((x x))
tonyg@24 484 (if (null? x)
tonyg@24 485 acc
tonyg@24 486 (let ((head (car x)))
tonyg@24 487 (f head (loop (cdr x))))))))
tonygarnockjones@308 488 (list 'list? '(lambda (xs)
tonygarnockjones@308 489 (let loop ((xs xs))
tonygarnockjones@308 490 (if (null? xs)
tonygarnockjones@308 491 #t
tonygarnockjones@308 492 (if (pair? xs)
tonygarnockjones@308 493 (loop (cdr xs))
tonygarnockjones@308 494 #f)))))
tonygarnockjones@308 495 (list 'list-of '(lambda (c)
tonygarnockjones@308 496 (lambda (xs)
tonygarnockjones@308 497 (let loop ((xs xs))
tonygarnockjones@308 498 (if (null? xs)
tonygarnockjones@308 499 #t
tonygarnockjones@308 500 (if (pair? xs)
tonygarnockjones@308 501 (if (c (car xs))
tonygarnockjones@308 502 (loop (cdr xs))
tonygarnockjones@308 503 #f)
tonygarnockjones@308 504 #f))))))
tonygarnockjones@308 505 (list 'any/c '(lambda (x)
tonygarnockjones@308 506 (filter 'unfold)
tonygarnockjones@308 507 #t))
tonyg@24 508 (list 'map '(lambda (f x)
tonyg@24 509 (filter 'unfold)
tonyg@24 510 (fold-right (lambda (v c)
tonyg@24 511 (filter 'unfold)
tonyg@24 512 (cons (f v) c)) '() x)))
tonyg@24 513 (list 'append '(lambda (a b)
tonyg@24 514 (filter 'unfold)
tonyg@24 515 (fold-right cons b a)))
tonyg@24 516 )))
tonyg@24 517
tonyg@170 518 (define (basic-env/streams)
tonyg@170 519 (fold (lambda (entry env)
tonygarnockjones@300 520 (cons (cons (car entry)
tonygarnockjones@300 521 (box (list (pe (parse (cadr entry) '()) env '()))))
tonyg@170 522 env))
tonyg@170 523 (basic-env)
tonyg@170 524 (list
tonyg@170 525 (list 'make-stream '(lambda* (stepper state)
tonyg@175 526 (cons 'stream (cons stepper (cons state '())))))
tonyg@170 527 (list 'stream-stepper '(lambda* (stream)
tonyg@170 528 (PRIMcar (PRIMcdr stream))))
tonyg@170 529 (list 'stream-state '(lambda* (stream)
tonyg@175 530 (PRIMcar (PRIMcdr (PRIMcdr stream)))))
tonyg@170 531 (list 'stream-maker '(lambda* (stepper)
tonyg@170 532 (lambda* (state)
tonyg@170 533 (make-stream stepper state))))
tonyg@170 534 (list 'list-stream-stepper '(lambda (l done skip yield)
tonyg@170 535 (if (null? l)
tonyg@170 536 (done)
tonyg@170 537 (yield (car l) (cdr l)))))
tonyg@170 538 (list 'list->stream '(stream-maker list-stream-stepper))
tonyg@170 539 (list 'string->stream '(lambda* (s)
tonyg@170 540 (make-stream (lambda (index done skip yield)
tonyg@170 541 (filter '(#f #t #t #t))
tonyg@170 542 (if (= index (string-length s))
tonyg@170 543 (done)
tonyg@170 544 (yield (string-ref s index)
tonyg@170 545 (+ index 1))))
tonyg@170 546 0)))
tonyg@170 547 (list 'smap
tonyg@170 548 '(lambda* (f stream)
tonyg@170 549 (let ((stepper (stream-stepper stream)))
tonyg@170 550 (make-stream (lambda* (state done skip yield)
tonyg@170 551 (stepper state
tonyg@170 552 done
tonyg@170 553 skip
tonyg@170 554 (lambda* (elt new-state) (yield (f elt) new-state))))
tonyg@170 555 (stream-state stream)))))
tonyg@170 556 (list 'sfilter '(lambda* (pred stream)
tonyg@170 557 (let ((stepper (stream-stepper stream)))
tonyg@170 558 (make-stream (lambda* (state done skip yield)
tonyg@170 559 (stepper state
tonyg@170 560 done
tonyg@170 561 skip
tonyg@170 562 (lambda* (elt new-state)
tonyg@170 563 (if (pred elt)
tonyg@170 564 (yield elt new-state)
tonyg@170 565 (skip new-state)))))
tonyg@170 566 (stream-state stream)))))
tonyg@170 567 (list 'sfoldr
tonyg@170 568 '(lambda* (kons knil stream)
tonyg@170 569 (let ((stepper (stream-stepper stream)))
tonyg@170 570 (let loop ((state (stream-state stream)))
tonyg@170 571 (stepper state
tonyg@170 572 (lambda* () knil)
tonyg@170 573 (lambda* (new-state) (loop new-state))
tonyg@170 574 (lambda* (elt new-state) (kons elt (loop new-state))))))))
tonyg@176 575 (list 'sfoldl
tonyg@176 576 '(lambda* (kons knil stream)
tonyg@176 577 (let ((stepper (stream-stepper stream)))
tonyg@176 578 (let loop ((knil knil)
tonyg@176 579 (state (stream-state stream)))
tonyg@176 580 (stepper state
tonyg@176 581 (lambda* () knil)
tonyg@176 582 (lambda* (new-state) (loop new-state))
tonyg@176 583 (lambda* (elt new-state) (loop (kons elt knil) new-state)))))))
tonyg@170 584 (list 'stream->list '(lambda* (stream)
tonyg@170 585 (sfoldr cons '() stream)))
tonyg@170 586 (list 'make-szip-state '(lambda* (cell left right)
tonyg@170 587 (cons cell (cons left (cons right '())))))
tonyg@170 588 (list 'szip-state-cell '(lambda* (s) (PRIMcar s)))
tonyg@170 589 (list 'szip-state-left '(lambda* (s) (PRIMcar (PRIMcdr s))))
tonyg@170 590 (list 'szip-state-right '(lambda* (s) (PRIMcar (PRIMcdr (PRIMcdr s)))))
tonyg@170 591 (list 'szip
tonyg@170 592 '(lambda* (left right)
tonyg@170 593 (let ((left-stepper (stream-stepper left))
tonyg@170 594 (right-stepper (stream-stepper right)))
tonyg@170 595 (make-stream
tonyg@170 596 (lambda (state done skip yield)
tonyg@170 597 ;;(filter (if (sval-known? (szip-state-cell state)) 'unfold '(#f #f #f #f)))
tonyg@170 598 (let ((cell (szip-state-cell state)))
tonyg@170 599 (cond
tonyg@170 600 ((null? cell)
tonyg@170 601 (right-stepper
tonyg@170 602 (szip-state-right state)
tonyg@170 603 done
tonyg@170 604 (lambda* (new-right)
tonyg@170 605 (skip (make-szip-state '() (szip-state-left state) new-right)))
tonyg@170 606 (lambda* (elt new-right)
tonyg@170 607 (skip (make-szip-state (cons elt '()) (szip-state-left state) new-right)))))
tonyg@170 608 (else
tonyg@170 609 (left-stepper
tonyg@170 610 (szip-state-left state)
tonyg@170 611 done
tonyg@170 612 (lambda* (new-left)
tonyg@170 613 (skip (make-szip-state cell new-left (szip-state-right state))))
tonyg@170 614 (lambda* (elt new-left)
tonyg@170 615 (yield (cons elt cell)
tonyg@170 616 (make-szip-state '() new-left (szip-state-right state)))))))))
tonyg@170 617 (make-szip-state '() (stream-state left) (stream-state right))))))
tonyg@177 618 (list 'make-sconcatmap-state '(lambda* (fstep fstate rs)
tonyg@177 619 (cons fstep (cons fstate (cons rs '())))))
tonyg@177 620 (list 'sconcatmap-state-first-stepper '(lambda* (s) (PRIMcar s)))
tonyg@177 621 (list 'sconcatmap-state-first-state '(lambda* (s) (PRIMcar (PRIMcdr s))))
tonyg@177 622 (list 'sconcatmap-state-remaining-streams '(lambda* (s) (PRIMcar (PRIMcdr (PRIMcdr s)))))
tonyg@177 623 (list 'sconcatmap
tonyg@177 624 '(lambda* (f streams)
tonyg@177 625 (let ((remaining-streams-stepper (stream-stepper streams)))
tonyg@177 626 (make-stream (lambda (state done skip yield)
tonyg@177 627 (let ((first-stepper (sconcatmap-state-first-stepper state)))
tonyg@177 628 (if first-stepper
tonyg@177 629 (first-stepper
tonyg@177 630 (sconcatmap-state-first-state state)
tonyg@177 631 (lambda* ()
tonyg@177 632 (skip (make-sconcatmap-state
tonyg@177 633 #f #f
tonyg@177 634 (sconcatmap-state-remaining-streams state))))
tonyg@177 635 (lambda* (new-first-state)
tonyg@177 636 (skip (make-sconcatmap-state
tonyg@177 637 first-stepper new-first-state
tonyg@177 638 (sconcatmap-state-remaining-streams state))))
tonyg@177 639 (lambda* (elt new-first-state)
tonyg@177 640 (yield elt
tonyg@177 641 (make-sconcatmap-state
tonyg@177 642 first-stepper new-first-state
tonyg@177 643 (sconcatmap-state-remaining-streams state)))))
tonyg@177 644 (remaining-streams-stepper
tonyg@177 645 (sconcatmap-state-remaining-streams state)
tonyg@177 646 done
tonyg@177 647 (lambda* (new-remaining-streams)
tonyg@177 648 (skip (make-sconcatmap-state
tonyg@177 649 #f #f
tonyg@177 650 new-remaining-streams)))
tonyg@177 651 (lambda* (first new-remaining-streams)
tonyg@177 652 (let ((first-stream (f first)))
tonyg@177 653 (skip (make-sconcatmap-state
tonyg@177 654 (stream-stepper first-stream)
tonyg@177 655 (stream-state first-stream)
tonyg@177 656 new-remaining-streams))))))))
tonyg@177 657 (make-sconcatmap-state #f #f (stream-state streams))))))
tonyg@177 658 (list 'sconcatenate
tonyg@177 659 '(lambda* (streams)
tonyg@177 660 (sconcatmap (lambda* (stream) stream) streams)))
tonyg@170 661 )))
tonyg@170 662
tonyg@24 663 (define (test-exp exp)
tonyg@170 664 (pe (parse exp '()) (basic-env/streams) '()))
tonyg@24 665
tonyg@24 666 (define (test)
tonyg@24 667 (let ((result (test-exp '(map (lambda (x)
tonyg@24 668 (filter 'unfold)
tonyg@24 669 (+ x 1))
tonyg@24 670 (append '(1 2) rest)))))
tonyg@24 671 (pretty-print 'test-done)
tonyg@24 672 (pretty-print (codegen result))))
tonyg@24 673
tonyg@24 674 (define (popt exp)
tonyg@24 675 (pretty-print (codegen (test-exp exp))))
tonyg@24 676
tonyg@24 677 (define even-exp
tonyg@24 678 '(lambda (x)
tonyg@24 679 ;; eta-conversion here to stop the letrec from being elided
tonyg@24 680 ;; because of bug described above.
tonyg@24 681 (letrec ((odd? (lambda (x1)
tonyg@24 682 (if (zero? x1)
tonyg@24 683 #f
tonyg@24 684 (even? (- x1 1)))))
tonyg@24 685 (even? (lambda (x2)
tonyg@24 686 (filter 'unfold)
tonyg@24 687 (if (zero? x2)
tonyg@24 688 #t
tonyg@24 689 (odd? (- x2 1))))))
tonyg@24 690 (even? x))))
tonyg@24 691
tonyg@24 692 (define fib-exp
tonyg@24 693 '(letrec ((fib (lambda (n)
tonyg@24 694 (if (< n 2)
tonyg@24 695 n
tonyg@24 696 (+ (fib (- n 1))
tonyg@24 697 (fib (- n 2)))))))
tonyg@24 698 (fib arg)))
tonyg@164 699
tonyg@164 700 (define curried-exp
tonyg@164 701 '((((lambda (a)
tonyg@164 702 (lambda (b)
tonyg@164 703 (lambda (c)
tonyg@164 704 (do-something-with a b c))))
tonyg@164 705 'aa)
tonyg@164 706 (bb))
tonyg@164 707 'cc))
tonyg@165 708
tonyg@178 709 (define curried-exp2
tonyg@178 710 '(let ((bv (bb)))
tonyg@178 711 ((((lambda (a)
tonyg@178 712 (lambda (b)
tonyg@178 713 (lambda (c)
tonyg@178 714 (do-something-with a b c))))
tonyg@178 715 'aa)
tonyg@178 716 bv)
tonyg@178 717 'cc)))
tonyg@178 718
tonyg@165 719 (define curried-cps-exp
tonyg@165 720 '((lambda (k a) (k (lambda (k b) (k (lambda (k c) (do-something-with k a b c))))))
tonyg@165 721 (lambda (bf) (bf (lambda (cf) (cf (lambda (x) (begin x))
tonyg@165 722 'cc))
tonyg@165 723 (bb)))
tonyg@165 724 'aa))
tonyg@178 725
tonyg@178 726 (define code-duplication-exp
tonyg@178 727 '(let ((x (f a b c)))
tonyg@178 728 (let ((y (g x x)))
tonyg@178 729 (h y y))))
tonyg@178 730
tonygarnockjones@301 731 (define filtering-mapping-exp
tonygarnockjones@301 732 '(fold (lambda* (elt acc)
tonygarnockjones@301 733 (if (even? elt)
tonygarnockjones@301 734 (cons elt acc)
tonygarnockjones@301 735 acc))
tonygarnockjones@301 736 '()
tonygarnockjones@301 737 (map (lambda* (x) (* x 2)) mylist)))
tonygarnockjones@301 738
tonygarnockjones@301 739 (define filtering-mapping-exp2
tonygarnockjones@301 740 '(fold (lambda* (elt acc)
tonygarnockjones@301 741 (if (even? elt)
tonygarnockjones@301 742 (cons elt acc)
tonygarnockjones@301 743 acc))
tonygarnockjones@301 744 '()
tonygarnockjones@301 745 (map (lambda* (x) (* x 2)) '(1 2 3 4 5))))
tonygarnockjones@301 746
tonygarnockjones@301 747 (define sfiltering-smapping-exp
tonygarnockjones@301 748 '(stream->list
tonygarnockjones@301 749 (sfilter (lambda* (elt)
tonygarnockjones@301 750 (even? elt))
tonygarnockjones@301 751 (smap (lambda* (x)
tonygarnockjones@301 752 (* x 2))
tonygarnockjones@301 753 (list->stream mylist)))))
tonygarnockjones@301 754
tonygarnockjones@301 755 (define sfiltering-smapping-exp1
tonygarnockjones@301 756 '(sfilter (lambda* (elt)
tonygarnockjones@301 757 (even? elt))
tonygarnockjones@301 758 (smap (lambda* (x)
tonygarnockjones@301 759 (* x 2))
tonygarnockjones@301 760 mystream)))
tonygarnockjones@301 761
tonygarnockjones@301 762 (define sfiltering-smapping-exp2
tonygarnockjones@301 763 '(stream->list
tonygarnockjones@301 764 (sfilter (lambda* (elt)
tonygarnockjones@301 765 (even? elt))
tonygarnockjones@301 766 (smap (lambda* (x)
tonygarnockjones@301 767 (* x 2))
tonygarnockjones@301 768 (list->stream '(1 2 3 4 5))))))
tonygarnockjones@301 769
tonygarnockjones@310 770 (define list-serializer
tonygarnockjones@310 771 '(letrec ((ser (lambda* (x emit k)
tonygarnockjones@310 772 (if (pair? x)
tonygarnockjones@310 773 (emit 'open
tonygarnockjones@310 774 (lambda* (emit)
tonygarnockjones@310 775 (letrec ((serlist (lambda* (xs emit k)
tonygarnockjones@310 776 (if (pair? xs)
tonygarnockjones@310 777 (ser (car x) emit
tonygarnockjones@310 778 (lambda* (emit)
tonygarnockjones@310 779 (serlist (cdr xs) emit k)))
tonygarnockjones@310 780 (k emit)))))
tonygarnockjones@310 781 (serlist x emit (lambda* (emit)
tonygarnockjones@310 782 (emit 'close k))))))
tonygarnockjones@310 783 (if (number? x)
tonygarnockjones@310 784 (emit x k)
tonygarnockjones@310 785 (error 'not-supported-in-ser))))))
tonygarnockjones@310 786 (letrec ((collect (lambda* (v k)
tonygarnockjones@310 787 (cons v (k collect)))))
tonygarnockjones@310 788 (ser '(12 22 32)
tonygarnockjones@310 789 collect
tonygarnockjones@310 790 (lambda* (emit) '())))))
tonygarnockjones@310 791
tonyg@178 792 ;;; Local Variables:
tonyg@178 793 ;;; eval: (put 'lambda* 'scheme-indent-function 1)
tonyg@178 794 ;;; End: