Jones N.D.Partial evaluation and automatic program generation.1999

The components of the Scheme0 specializer 381

)))))))))))

(define (desug* es sub) (map (lambda (e) (desug e sub)) es)) (define (desugardef def)

(list 'define (cons (name def) (var def)) (desug (body def) ()))) (map desugardef program)

)

; Define Scheme functions corresponding to abbreviations (define (sugartoscheme abbrevtriple)

(list 'define (list abbrev var)

(if (and (pair? term) (equal? (car term) 'op)) (cdr term) term)

)))

; Convert plain Scheme0 programs to Scheme, possibly renaming functions

(define (scheme program) (define (rename fn)

(define (variant f)

(let ((original (car (car f))) (btvariant (cdr f))) (foldl string-append ""

(map symbol->string (cons original (cons '* btvariant)))))) (define (gi f vs defs)

(if defs

(let ((fvs (name (car defs)))) (if (equal? f (car fvs))

(if (equal? vs (cdr fvs)) 1

(+ 1 (gi f vs (cdr defs)))) (gi f vs (cdr defs))))

(error 'rename "Unknown function: ~s" (cons f vs)))) (if (atom? fn)

fn

(let ((f (car fn)) (vs (cdr fn))) (string->symbol

(string-append (variant f) "-"

(number->string (gi f vs program)))))))

(define (schdef def) (list 'define

(cons (rename (name def)) (var def)) (schexp (body def))))

(define (schexp e)

(if (equal? (tag e) 'quote) e (if (equal? (tag e) 'if)

(list 'if (schexp (e1 e)) (schexp (e2 e)) (schexp (e3 e))) (if (equal? (tag e) 'call)

(cons (rename (funname e)) (map schexp (callargs e))) (if (equal? (tag e) 'op)

(cons (funname e) (map schexp (callargs e)))

(error 'scheme "Illegal Scheme0 expression: ~s" e))))))))) (map schdef program)

)

(define (reorder parameters sdpattern) (if parameters

(let ((pspd (reorder (cdr parameters) (cdr sdpattern)))) (if (equal? (car sdpattern) 'S)

(cons (cons (car parameters) (car pspd)) (cdr pspd)) (cons (car pspd) (cons (car parameters) (cdr pspd)))))

(cons () ())

The components of the Scheme0 specializer 383

;File "analyse.ss" -- Binding time analysis of Scheme0 programs

;Partial evaluator for first order functional language

;General (monovariant or polyvariant) binding time analysis

(define (finddivision program sdpattern update) (define (bv e vn vt division)

(if (equal? (tag e) 'quote) division (if (equal? (tag e) 'if)

(bv (e1 e) vn vt (bv (e2 e) vn vt (bv (e3 e) vn vt division))) (if (equal? (tag e) 'call)

(let ((argsdpat (map (lambda (e) (be e vn vt)) (callargs e)))) (foldl (lambda (d e) (bv e vn vt d))

(update (funname e) argsdpat division bv) (callargs e)))

(if (equal? (tag e) 'op)

(foldl (lambda (d e) (bv e vn vt d)) division (callargs e)) (error 'bv '"Illegal Scheme0 expression: ~s" e)

))))))))

(let ((def (car program)))

(let ((division0 (list (cons (name def) (list sdpattern))))) (bv (body def) (var def) sdpattern division0)

)))

; Monovariant binding time analysis

(define (monodiv program sdpattern) (define (monoupdate f sdpat div0 bv)

(define (monoupd div0) (if div0

(let ((d1 (car div0))) (if (equal? f (car d1))

(let ((oldsdpattern (car (cdr d1))))

(cons (cons f (list (lub* sdpat oldsdpattern))) (cdr div0)))

(cons d1 (monoupd (cdr div0))))) (list (cons f (list sdpat)))))

(let ((div1 (monoupd div0))) (if (equal? div0 div1)

div0

(let ((def (lookupfun f program)))

(bv (body def) (var def) (car (getsdpatterns f div1)) div1)

))))

(finddivision program sdpattern monoupdate)

)

; Polyvariant binding time analysis

(define (polydiv program sdpattern) (define (polyupdate f sdpat div0 bv)

(define (polyupd div0) (if div0

(let ((d1 (car div0))) (if (equal? f (car d1))

(let ((oldsdpatterns (cdr d1)))

(if (member sdpat oldsdpatterns) div0

(cons (cons f (append oldsdpatterns (list sdpat))) (cdr div0))))

(cons d1 (polyupd (cdr div0))))) (list (cons f (list sdpat)))))

The components of the Scheme0 specializer 385

;Partial evaluator for first order functional language

;Takes a Scheme0 program and a (possibly polyvariant) division; returns

;an annotated Scheme0 program or reports non-congruence of the division.

(define (annotate program division) (foldl append ()

(map (lambda (def) (anndef def program division)) program)

))

(define (anndef def program division) (define (anndefversion sdpattern)

(let ((xsxd (reorder (var def) sdpattern))) (list 'define

(list (cons (cons (name def)

(dynoccs (name def) sdpattern program)) sdpattern)

(car xsxd) (cdr xsxd))

((if (cdr xsxd) lift exp)

(annexp (body def) (var def) sdpattern onlineunfolding))))) (define (annexp e vn vt unf)

(if (null? e) (cons e 'S) (if (number? e) (cons e 'S)

(if (atom? e) (cons e (lookupbt e vn vt)) (if (equal? (tag e) 'quote) (cons e 'S) (if (equal? (tag e) 'if)

(let ((ae1 (annexp (e1 e) vn vt unf)))

(let ((ae2 (annexp (e2 e) vn vt (and unf (static ae1)))) (ae3 (annexp (e3 e) vn vt (and unf (static ae1)))))

(if (static ae1)

(if (and (static ae2) (static ae3))

(cons (list 'ifs (exp ae1) (exp ae2) (exp ae3)) 'S) (cons (list 'ifs (exp ae1) (lift ae2) (lift ae3)) 'D))

(cons (list 'ifd (exp ae1) (lift ae2) (lift ae3)) 'D)))) (if (equal? (tag e) 'call)

(let ((aes (map (lambda (e) (annexp e vn vt unf)) (callargs e))) (f (funname e)))

(let ((argsdpat (map cdr aes)))

(let ((sdpattern (getleast argsdpat (getsdpatterns f division) f))) (let ((esed (reorder aes sdpattern))

(dynvaroccs (dynoccs f sdpattern program))) (let ((es (car esed)) (ed (cdr esed)))

(let ((staticcall (or (null? ed)

(and unf (nodup dynvaroccs (map exp ed)))))) (cons (list (if staticcall 'calls 'calld)

(cons (cons f dynvaroccs) sdpattern) (map exp es)

(map lift ed))

(if (null? ed) 'S 'D)))))))) (if (equal? (tag e) 'op)

(let ((aes (map (lambda (e) (annexp e vn vt unf)) (callargs e)))) (if (all (map static aes))

(cons (cons 'ops (cons (funname e) (map exp aes))) 'S) (cons (cons 'opd (cons (funname e) (map lift aes))) 'D)))

(error 'annotate "Illegal Scheme0 expression: ~s" e)

))))))))

(map anndefversion (getsdpatterns (name def) division))

)

(define (dynoccs f sdpattern program) (let ((def (lookupfun f program))) (let ((vn (var def)))

(let ((occs (count (body def) vn sdpattern (map (lambda (v) 0) vn)))) (cdr (reorder occs sdpattern))

386 The Self-Applicable Scheme0 Specializer

))))

;Count occurrences of all variables vn in e, giving a list of 0, 1, or 2,

;(meaning 0, 1, or >= 2) occurrences of the corresponding variable in vn.

(define (count e vn vt occurrences) (if (null? e) occurrences

(if (number? e) occurrences

(if (atom? e) (incvar e vn occurrences) (if (equal? (tag e) 'quote) occurrences (if (equal? (tag e) 'if)

(if (equal? (be (e1 e) vn vt) 'S)

(count (e1 e) vn vt (maxoccs (count (e2 e) vn vt occurrences) (count (e3 e) vn vt occurrences)))

(count (e1 e) vn vt (count (e2 e) vn vt

(count (e3 e) vn vt occurrences)))) (if (or (equal? (tag e) 'call) (equal? (tag e) 'op))

(foldl (lambda (occs e)(count e vn vt occs)) occurrences (callargs e)) (error 'count "Illegal Scheme0 expression: ~s" e)

)))))))

(define (incvar x vn occurrences) (if vn

(if (equal? x (car vn))

(cons (if (equal? (car occurrences) 0) 1 2) (cdr occurrences))

(cons (car occurrences) (incvar x (cdr vn) (cdr occurrences)))) (error 'incvar "Unknown variable: ~s" x)

))

(define (maxoccs occs1 occs2)

(if occs1 (cons (max (car occs1) (car occs2)) (maxoccs (cdr occs1) (cdr occs2)))

()

))

(define (static ae) (equal? (cdr ae) 'S))

(define (exp ae) (car ae))

(define (lift ae) (if (static ae) (list 'lift (car ae)) (car ae)))

; Find least sdpattern in sdpatterns which is compatible with sdpat

(define (getleast sdpat sdpatterns f) (if sdpatterns

(if (sdpattern-leq sdpat (car sdpatterns)) (car sdpatterns)

(getleast sdpat (cdr sdpatterns) f))

(error 'annotate "Incongruent division ~s at function ~s" sdpat f)

))

The le specialize.ss de nes the specializer itself and its auxiliary functions (successors, diff, lookupfun, . . . ).

;File "spec.ss" -- The specializer written in Scheme0

;Partial evaluator for first order functional language

;The specializer itself, written in Scheme0. Inputs: annotated Scheme0

;program and values of the static parameters. Output: a Scheme0 program.

The components of the Scheme0 specializer 387

(define specializer (desugar '(

(define (specialize program vs0)

(call complete (list (:: (name (hd program)) vs0)) () program)

)

(define (complete pending marked program) (if pending

(call generate (hd pending) program pending marked program) ()

))

(define (generate fvs defs pending marked program) (if defs

(slet (def (hd defs))

(if (op equal? (name def) (hd fvs))

(slet (evs (call reduce (body def) (svar def) (tl fvs) (dvar def) (dvar def) program))

(slet (newmarked (:: fvs marked))

(call gen1 def evs fvs pending newmarked program))) (call generate fvs (tl defs) pending marked program)))

(op error 'generate '"Undefined function: ~s" (hd fvs))

))

(define (gen1 def evs fvs pending newmarked program)

(slet (newpending (op diff (op successors evs pending) newmarked))

(if (call reduce (e1 e) xs vs xd vd p) (call reduce (e2 e) xs vs xd vd p) (call reduce (e3 e) xs vs xd vd p))

(if (op equal? (tag e) 'ifd)

(list 'if (call reduce (e1 e) xs vs xd vd p) (call reduce (e2 e) xs vs xd vd p) (call reduce (e3 e) xs vs xd vd p))

(if (op equal? (tag e) 'calls)

(call docalls (op lookupfun (funname e) p) p (call reduce* (sfunargs e) xs vs xd vd p) (call reduce* (dfunargs e) xs vs xd vd p))

(if (op equal? (tag e) 'calld) (:: 'call

(:: (:: (funname e) (call reduce* (sfunargs e) xs vs xd vd p)) (call reduce* (dfunargs e) xs vs xd vd p)))

(if (op equal? (tag e) 'ops)

(op evalbase (funname e) (call reduce* (callargs e) xs vs xd vd p)) (if (op equal? (tag e) 'opd)

(:: 'op (:: (funname e) (call reduce* (callargs e) xs vs xd vd p))) (if (op equal? (tag e) 'lift)

(list 'quote (call reduce (e1 e) xs vs xd vd p))

(op error 'reduce '"Illegal annotated Scheme0 expression: ~s" e)

))))))))))))

(define (reduce* es xs vs xd vd p) (if es

(:: (call reduce (hd es) xs vs xd vd p) (call reduce* (tl es) xs vs xd vd p))

'()

388 The Self-Applicable Scheme0 Specializer

))

(define (docalls def p args argd)

(if (op nodup (tl (hd (name def))) argd)

(call reduce (body def) (svar def) args (dvar def) argd p) (:: 'call (:: (:: (name def) args) argd))

))

(define (lookupvar x xs vs xd vd) (if xs

(if (op equal? x (hd xs)) (hd vs)

(call lookupvar x (tl xs) (tl vs) xd vd)) (call lookupvar x xd vd 'slam 'slam)

))

)))

; Auxiliary base functions for the specializer

(define (successors e s)

(if (equal? (tag e) 'call)

(successors* (callargs e) (cons (funname e) s)) (if (equal? (tag e) 'op)

(successors* (callargs e) s)

(error 'successors '"Illegal Scheme0 expression: ~s" e)

))))))))

(define (successors* es s) (foldl (lambda (s e) (successors e s)) s es))

(define (diff set1 set2) (if set1

(if (member (car set1) set2) (diff (cdr set1) set2)

(cons (car set1) (diff (cdr set1) set2)))

()

))

(define (nodup occs exps) (if occs

(and (or (atom? (car exps)) (< (car occs) 2)) (nodup (cdr occs) (cdr exps)))

't

))

(define (lookupfun f program) (if program

(if (equal? f (name (car program))) (car program)

(lookupfun f (cdr program)))

(error 'lookupfun '"Undefined function: ~s" f)

))

(define (evalbase f args) (apply (s0eval f) args))

390Bibliography

[13]A. Appel, `Reopening closures'. Personal communication, January 1988.

[14]W.-Y. Au, D. Weise, and S. Seligman, `Generating compiled simulations using partial evaluation', in 28th Design Automation Conference, pp. 205{210, New York: IEEE, June 1991.

[15]L. Augustsson, `Compiling pattern matching', in J.-P. Jouannaud (ed.), Functional Programming Languages and Computer Architecture, Nancy, France, 1985 (Lecture Notes in Computer Science, vol. 201), pp. 368{381, Berlin: Springer-Verlag, 1985.

[16]H.P. Barendregt, The Lambda Calculus: Its Syntax and Semantics, Amsterdam: NorthHolland, second edition, 1984.

[17]K.E. Batcher, `Sorting networks and their applications', in Proceedings AFIPS Spring Joint Computer Conference, pp. 307{314, American Federation of Information Processing Societies, 1968.

[18]D. Bechet, `Partial evaluation of interaction nets', in M. Billaud et al. (eds.), WSA '92, Static Analysis, Bordeaux, France, September 1992. Bigre vols 81{82, 1992, pp. 331{338, Rennes: IRISA, 1992.

[19]L. Beckman et al., `A partial evaluator, and its use as a programming tool', Arti cial Intelligence, 7(4):319{357, 1976.

[20] K. Benkerimi and J.W. Lloyd, `A partial evaluation procedure for logic programs', in

S.Debray and M. Hermenegildo (eds.), Logic Programming: Proceedings of the 1990 North American Conference, Austin, Texas, October 1990, pp. 343{358, Cambridge, MA: MIT Press, 1990.

[21]A. Berlin and D. Weise, `Compiling scienti c code using partial evaluation', IEEE Computer, 23(12):25{37, December 1990.

[22]A.A. Berlin, `Partial evaluation applied to numerical computation', in 1990 ACM Conference on Lisp and Functional Programming, Nice, France, pp. 139{150, New York: ACM, 1990.

[23]R.S. Bird, `Improving programs by the introduction of recursion', Communications of the ACM, 20(11):856{863, 1977.

[24]D. Bj rner, A.P. Ershov, and N.D. Jones (eds.), Partial Evaluation and Mixed Computation. Proceedings of the IFIP TC2 Workshop, Gammel Avern s, Denmark, October 1987, Amsterdam: North-Holland, 1988.

[25]D. Bj rner and C.B. Jones, Formal Speci cation and Software Development, Englewood Cli s, NJ: Prentice Hall, 1982.

[26]A. Bondorf, `Towards a self-applicable partial evaluator for term rewriting systems', in

D.Bj rner, A.P. Ershov, and N.D. Jones (eds.), Partial Evaluation and Mixed Computation, pp. 27{50, Amsterdam: North-Holland, 1988.

[27]A. Bondorf, `Self-applicable partial evaluation', Ph.D. thesis, DIKU, University of Copenhagen, Denmark, 1990. Revised version: DIKU Report 90/17.

[28]A. Bondorf, `Automatic autoprojection of higher order recursive equations', Science of Computer Programming, 17:3{34, 1991.

[29]A. Bondorf, Similix Manual, System Version 3.0, Technical Report 91/9, DIKU, University of Copenhagen, Denmark, 1991.

[30]A. Bondorf, Similix Manual, System Version 4.0, technical report, DIKU, University of Copenhagen, Denmark, 1991.