176 lines
5.0 KiB
Plaintext
176 lines
5.0 KiB
Plaintext
|
Return-Path: <kelsey@ccs.neu.edu>
|
||
|
|
Date: Mon, 14 Jun 93 14:34:40 -0400
|
||
|
|
To: jar@cs.cornell.edu
|
||
|
|
Subject: environments for leaf procedures
|
||
|
|
From: kelsey@flora.ccs.neu.edu
|
||
|
|
Sender: kelsey@ccs.neu.edu
|
||
|
|
|
||
|
|
|
||
|
|
I merged the no-leaf-environments code back into the system, and this
|
||
|
|
time it may be worth it. Loading pp.scm sped up by 2%, even though
|
||
|
|
the compiler is doing more work. Benchmark times (in seconds):
|
||
|
|
|
||
|
|
old new speedup
|
||
|
|
quicksort 1.48 1.39 6%
|
||
|
|
towers 1.05 1.05 0%
|
||
|
|
matrix-multiply 3.32 3.10 7%
|
||
|
|
matrix-multiply2 1.94 1.80 7%
|
||
|
|
|
||
|
|
Local variable names are screwed up:
|
||
|
|
|
||
|
|
> (define (f x) (let ((y 4)) (+ x y)))
|
||
|
|
> (f 'a)
|
||
|
|
|
||
|
|
Error: exception
|
||
|
|
(+ 'a 4)
|
||
|
|
1> ,debug
|
||
|
|
'#{Continuation (pc 13) f}
|
||
|
|
|
||
|
|
[0] 4
|
||
|
|
[1: y] 'a
|
||
|
|
inspect:
|
||
|
|
|
||
|
|
There is probably a simple fix for this.
|
||
|
|
|
||
|
|
Here is the diff:
|
||
|
|
|
||
|
|
% diff comp.scm comp.scm.save
|
||
|
|
26d25
|
||
|
|
< (define $compiling-leaf (make-fluid 'no))
|
||
|
|
28,33d26
|
||
|
|
< (define (note-not-leaf!)
|
||
|
|
< (set-fluid! $compiling-leaf 'no))
|
||
|
|
<
|
||
|
|
< (define (compiling-leaf?)
|
||
|
|
< (eq? 'yes (fluid $compiling-leaf)))
|
||
|
|
<
|
||
|
|
63,82c56,66
|
||
|
|
< (deliver-value (if (env-ref? den)
|
||
|
|
< (local-variable den cenv depth #f)
|
||
|
|
< (instruction-with-variable op/global exp den #f))
|
||
|
|
< cont)))
|
||
|
|
<
|
||
|
|
< (define (local-variable den cenv depth set?)
|
||
|
|
< (let ((back (env-ref-back den cenv))
|
||
|
|
< (over (env-ref-over den)))
|
||
|
|
< (if (and (compiling-leaf?)
|
||
|
|
< (= back 0))
|
||
|
|
< (instruction (if set? op/stack-set! op/stack-ref)
|
||
|
|
< (+ (- over 1) depth))
|
||
|
|
< (let ((back (if (compiling-leaf?) (- back 1) back)))
|
||
|
|
< (if set?
|
||
|
|
< (instruction op/set-local! back over)
|
||
|
|
< (case back
|
||
|
|
< ((0) (instruction op/local0 over)) ;+++
|
||
|
|
< ((1) (instruction op/local1 over)) ;+++
|
||
|
|
< ((2) (instruction op/local2 over)) ;+++
|
||
|
|
< (else (instruction op/local back over))))))))
|
||
|
|
---
|
||
|
|
> (if (env-ref? den)
|
||
|
|
> (let ((back (env-ref-back den cenv))
|
||
|
|
> (over (env-ref-over den)))
|
||
|
|
> (deliver-value (case back
|
||
|
|
> ((0) (instruction op/local0 over)) ;+++
|
||
|
|
> ((1) (instruction op/local1 over)) ;+++
|
||
|
|
> ((2) (instruction op/local2 over)) ;+++
|
||
|
|
> (else (instruction op/local back over)))
|
||
|
|
> cont))
|
||
|
|
> (deliver-value (instruction-with-variable op/global exp den #f)
|
||
|
|
> cont))))
|
||
|
|
143,145c127,132
|
||
|
|
< (if (env-ref? den)
|
||
|
|
< (local-variable den cenv depth #t)
|
||
|
|
< (instruction-with-variable op/set-global! name den #t)))
|
||
|
|
---
|
||
|
|
> (cond ((env-ref? den)
|
||
|
|
> (instruction op/set-local!
|
||
|
|
> (env-ref-back den cenv)
|
||
|
|
> (env-ref-over den)))
|
||
|
|
> (else
|
||
|
|
> (instruction-with-variable op/set-global! name den #t))))
|
||
|
|
203d189
|
||
|
|
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
|
||
|
|
222,231c208,215
|
||
|
|
< (cond ((return-cont? cont)
|
||
|
|
< code)
|
||
|
|
< (else
|
||
|
|
< (note-not-leaf!) ; this isn't strictly necessary, but it keeps things simpler
|
||
|
|
< (sequentially (instruction-with-offset&byte op/make-cont
|
||
|
|
< (segment-size code)
|
||
|
|
< depth)
|
||
|
|
< (note-source-code (cont-source-info cont)
|
||
|
|
< code)
|
||
|
|
< (cont-segment cont)))))
|
||
|
|
---
|
||
|
|
> (if (return-cont? cont)
|
||
|
|
> code
|
||
|
|
> (sequentially (instruction-with-offset&byte op/make-cont
|
||
|
|
> (segment-size code)
|
||
|
|
> depth)
|
||
|
|
> (note-source-code (cont-source-info cont)
|
||
|
|
> code)
|
||
|
|
> (cont-segment cont))))
|
||
|
|
264d247
|
||
|
|
< (note-not-leaf!)
|
||
|
|
280,315c263,284
|
||
|
|
< (let-fluids $compiling-leaf 'maybe
|
||
|
|
< (lambda ()
|
||
|
|
< (let ((code (really-compile-lambda-code formals body cenv name)))
|
||
|
|
< (if (eq? (fluid $compiling-leaf) 'maybe)
|
||
|
|
< (let-fluids $compiling-leaf 'yes
|
||
|
|
< (lambda ()
|
||
|
|
< (really-compile-lambda-code formals body cenv name)))
|
||
|
|
< code)))))
|
||
|
|
<
|
||
|
|
< (define (really-compile-lambda-code formals body cenv name)
|
||
|
|
< (let* ((nargs (number-of-required-args formals))
|
||
|
|
< (vars (normalize-formals formals))
|
||
|
|
< (cenv (if (null? formals)
|
||
|
|
< cenv ;+++
|
||
|
|
< (bind-vars vars cenv))))
|
||
|
|
< (sequentially
|
||
|
|
< (cond ((n-ary? formals)
|
||
|
|
< (sequentially
|
||
|
|
< (instruction op/make-rest-list nargs)
|
||
|
|
< (instruction op/push)
|
||
|
|
< (if (compiling-leaf?)
|
||
|
|
< empty-segment
|
||
|
|
< (instruction op/make-env (+ nargs 1)))))
|
||
|
|
< ((null? formals)
|
||
|
|
< (note-not-leaf!) ; no point if no variables
|
||
|
|
< empty-segment)
|
||
|
|
< ((compiling-leaf?)
|
||
|
|
< empty-segment)
|
||
|
|
< (else
|
||
|
|
< (instruction op/make-env nargs)))
|
||
|
|
< (note-environment
|
||
|
|
< vars
|
||
|
|
< (compile-body body
|
||
|
|
< cenv
|
||
|
|
< 0
|
||
|
|
< (return-cont name))))))
|
||
|
|
---
|
||
|
|
> (if (null? formals)
|
||
|
|
> (compile-body body ;+++ Don't make null environment
|
||
|
|
> cenv
|
||
|
|
> 0
|
||
|
|
> (return-cont name))
|
||
|
|
> (sequentially
|
||
|
|
> (let ((nargs (number-of-required-args formals)))
|
||
|
|
> (if (n-ary? formals)
|
||
|
|
> (sequentially
|
||
|
|
> (instruction op/make-rest-list nargs)
|
||
|
|
> (instruction op/push)
|
||
|
|
> (instruction op/make-env (+ nargs 1)))
|
||
|
|
> (instruction op/make-env nargs)))
|
||
|
|
> (let* ((vars (normalize-formals formals))
|
||
|
|
> (cenv (bind-vars vars cenv)))
|
||
|
|
> (note-environment
|
||
|
|
> vars
|
||
|
|
> (compile-body body
|
||
|
|
> cenv
|
||
|
|
> 0
|
||
|
|
> (return-cont name)))))))
|
||
|
|
>
|
||
|
|
|