Cette semaine l'exercice est d'expliquer les étapes du pipeline d'un compilateur Scheme typique: - lecture du code source (avec "read") - macro-expansion - alpha-conversion - assignment-conversion - closure-conversion Le code Scheme du compilateur qui implante ce pipeline (programme "scheme-pipeline.scm") est donné à la fin de ce document. Ci-dessous il y a deux traces d'exécution, sur les programmes "oddeven.scm" et "incdec.scm", avec la représentation interne après chaque étape. Il faut montrer aux étudiants les deux traces et expliquer ce que chaque transformation a fait. Le code final (après closure-conversion) est directement exécutable dans Gambit (avec un cut-and-paste) ce qui peut être utile pour tester. Le code de "scheme-pipeline.scm" pourra être réutilisé dans les projets des étudiants. =============================================================================== % gsi scheme-pipeline.scm oddeven.scm ---------------------------- source: (letrec ((odd (lambda (n) (if (= n 0) #f (even (- n 1))))) (even (lambda (n) (if (= n 0) #t (odd (- n 1)))))) (odd 13)) ---------------------------- after macro-expansion: (let ((odd #f) (even #f)) (let ((g1 (set! odd (lambda (n) (if (= n 0) #f (even (- n 1))))))) (let ((g2 (set! even (lambda (n) (if (= n 0) #t (odd (- n 1))))))) (odd 13)))) ---------------------------- after alpha-conversion: (let ((g3 #f) (g4 #f)) (let ((g5 (set! g3 (lambda (g6) (if (= g6 0) #f (g4 (- g6 1))))))) (let ((g7 (set! g4 (lambda (g8) (if (= g8 0) #t (g3 (- g8 1))))))) (g3 13)))) ---------------------------- after assignment-conversion: (let ((g9 #f) (g10 #f)) (let ((g3 (cons g9 '())) (g4 (cons g10 '()))) (let ((g5 (set-car! g3 (lambda (g6) (if (= g6 0) #f ((car g4) (- g6 1))))))) (let ((g7 (set-car! g4 (lambda (g8) (if (= g8 0) #t ((car g3) (- g8 1))))))) ((car g3) 13))))) ---------------------------- after closure-conversion: (define make-closure vector) (define closure-code (lambda (clo) (vector-ref clo 0))) (define closure-ref (lambda (clo i) (vector-ref clo (+ i 1)))) (let ((g9 #f) (g10 #f)) (let ((g3 (cons g9 '())) (g4 (cons g10 '()))) (let ((g5 (set-car! g3 (make-closure (lambda ($this g6) (if (= g6 0) #f (let (($clo (car (closure-ref $this 0)))) ((closure-code $clo) $clo (- g6 1))))) g4)))) (let ((g7 (set-car! g4 (make-closure (lambda ($this g8) (if (= g8 0) #t (let (($clo (car (closure-ref $this 0)))) ((closure-code $clo) $clo (- g8 1))))) g3)))) (let (($clo (car g3))) ((closure-code $clo) $clo 13)))))) =============================================================================== % gsi scheme-pipeline.scm incdec.scm ---------------------------- source: (define test (lambda (n) (cons (lambda (x) (begin (set! n (+ n x)) n)) (lambda (x) (begin (set! n (- n x)) n))))) (define p (test 0)) (define inc (car p)) (define dec (cdr p)) (inc 3) (inc 3) (dec 1) ---------------------------- after macro-expansion: (define test (lambda (n) (cons (lambda (x) (let ((g1 (set! n (+ n x)))) n)) (lambda (x) (let ((g2 (set! n (- n x)))) n))))) (define p (test 0)) (define inc (car p)) (define dec (cdr p)) (inc 3) (inc 3) (dec 1) ---------------------------- after alpha-conversion: (define test (lambda (g3) (cons (lambda (g4) (let ((g5 (set! g3 (+ g3 g4)))) g3)) (lambda (g6) (let ((g7 (set! g3 (- g3 g6)))) g3))))) (define p (test 0)) (define inc (car p)) (define dec (cdr p)) (inc 3) (inc 3) (dec 1) ---------------------------- after assignment-conversion: (define test (lambda (g8) (let ((g3 (cons g8 '()))) (cons (lambda (g4) (let ((g5 (set-car! g3 (+ (car g3) g4)))) (car g3))) (lambda (g6) (let ((g7 (set-car! g3 (- (car g3) g6)))) (car g3))))))) (define p (test 0)) (define inc (car p)) (define dec (cdr p)) (inc 3) (inc 3) (dec 1) ---------------------------- after closure-conversion: (define make-closure vector) (define closure-code (lambda (clo) (vector-ref clo 0))) (define closure-ref (lambda (clo i) (vector-ref clo (+ i 1)))) (define test (make-closure (lambda ($this g8) (let ((g3 (cons g8 '()))) (cons (make-closure (lambda ($this g4) (let ((g5 (set-car! (closure-ref $this 0) (+ (car (closure-ref $this 0)) g4)))) (car (closure-ref $this 0)))) g3) (make-closure (lambda ($this g6) (let ((g7 (set-car! (closure-ref $this 0) (- (car (closure-ref $this 0)) g6)))) (car (closure-ref $this 0)))) g3)))))) (define p (let (($clo test)) ((closure-code $clo) $clo 0))) (define inc (car p)) (define dec (cdr p)) (let (($clo inc)) ((closure-code $clo) $clo 3)) (let (($clo inc)) ((closure-code $clo) $clo 3)) (let (($clo dec)) ((closure-code $clo) $clo 1)) =============================================================================== #! /usr/bin/env gsi ;; File: "scheme-pipeline.scm" ;; This program demonstrates the stages of a typical Scheme compiler's ;; pipeline: ;; ;; - parsing (using "read") ;; - macro-expansion ;; - alpha-conversion ;; - assignment-conversion ;; - closure-conversion ;; ;; To try out this compiler, call it like this: ;; ;; % gsi scheme-pipeline.scm program.scm ;; ;; where "program.scm" is the program to compile. ;;;---------------------------------------------------------------------------- ;; Define some special forms to define macros that are usable ;; in macro definitions. (define-macro (for-macro-expansion . body) (eval `(begin ,@body)) #f) (define-macro (for-here-and-macro-expansion . body) `(begin (for-macro-expansion ,@body) ,@body)) ;;;---------------------------------------------------------------------------- ;; Define the match special form. (for-here-and-macro-expansion (define-macro (match sujet . clauses) (define (if-equal? var gab oui non) (cond ((and (pair? gab) (eq? (car gab) 'unquote) (pair? (cdr gab)) (null? (cddr gab))) `(let ((,(cadr gab) ,var)) ,oui)) ((null? gab) `(if (null? ,var) ,oui ,non)) ((symbol? gab) `(if (eq? ,var ',gab) ,oui ,non)) ((or (boolean? gab) (char? gab)) `(if (eq? ,var ,gab) ,oui ,non)) ((number? gab) `(if (eqv? ,var ,gab) ,oui ,non)) ((pair? gab) (let ((carvar (gensym)) (cdrvar (gensym))) `(if (pair? ,var) (let ((,carvar (car ,var))) ,(if-equal? carvar (car gab) `(let ((,cdrvar (cdr ,var))) ,(if-equal? cdrvar (cdr gab) oui non)) non)) ,non))) (else (error "unknown pattern")))) (let* ((var (gensym)) (fns (map (lambda (x) (gensym)) clauses)) (err (gensym))) `(let ((,var ,sujet)) ,@(map (lambda (fn1 fn2 clause) `(define (,fn1) ,(if-equal? var (car clause) (if (and (eq? (cadr clause) 'when) (pair? (cddr clause))) `(if ,(caddr clause) ,(cadddr clause) (,fn2)) (cadr clause)) `(,fn2)))) fns (append (cdr fns) (list err)) clauses) (define (,err) (error "match failed")) (,(car fns))))) (define gensym ;; a version of gensym that creates easier to read symbols (let ((count 0)) (lambda () (set! count (+ count 1)) (string->symbol (string-append "g" (number->string count)))))) ) ;;;---------------------------------------------------------------------------- ;; The macro expander. (define (expand expr) (match expr (,c when (constant? c) c) (,v when (symbol? v) v) ((quote ,x) `(quote ,x)) ((set! ,v ,E1) `(set! ,v ,(expand E1))) ((set! . ,rest) (error "improper set!")) ((define (,v . ,params) . ,Es) `(define ,v ,(expand `(lambda ,params ,@Es)))) ((define ,v ,E1) `(define ,v ,(expand E1))) ((define . ,rest) (error "improper define")) ((if ,E1 ,E2) `(if ,(expand E1) ,(expand E2) #f)) ((if ,E1 ,E2 ,E3) `(if ,(expand E1) ,(expand E2) ,(expand E3))) ((if . ,rest) (error "improper if")) ((begin ,E1) (expand E1)) ((begin ,E1 . ,Es) (expand (let ((v (gensym))) `(let ((,v ,E1)) (begin ,@Es))))) ((begin . ,Es) (error "improper begin")) ((lambda ,params . ,Es) `(lambda ,params ,(expand `(begin ,@Es)))) ((lambda . ,rest) (error "improper lambda")) ((let ,name ,bindings . ,Es) when (symbol? name) (expand `((letrec ((,name (lambda ,(map car bindings) ,@Es))) ,name) ,@(map cadr bindings)))) ;; don't convert let to lambda... let is considered a primitive form ;; ((let ,bindings . ,Es) ;; (expand ;; `((lambda ,(map car bindings) ,@Es) ;; ,@(map cadr bindings)))) ((let ,bindings . ,Es) `(let ,(map (lambda (b) (list (car b) (expand (cadr b)))) bindings) ,(expand `(begin ,@Es)))) ((let . ,rest) (error "improper let")) ((letrec ,bindings . ,Es) (expand `(let ,(map (lambda (b) `(,(car b) #f)) bindings) ,@(map (lambda (b) `(set! ,(car b) ,(cadr b))) bindings) ,@Es))) ((letrec . ,rest) (error "improper letrec")) ((cond) `#f) ((cond (else ,E1 . ,Es)) (expand `(begin ,E1 ,@Es))) ((cond (else . ,Es) . ,rest) (error "improper else clause")) ((cond (,test) . ,rest) (expand `(or ,test (cond ,@rest)))) ((cond (,test => ,fn) . ,rest) (expand (let ((v (gensym))) `(let ((,v ,test)) (if ,v (,fn ,v) (cond ,@rest)))))) ((cond (,test => . ,Es) . ,rest) (error "improper => clause")) ((cond (,test ,E1 . ,Es) . ,rest) (expand `(if ,test (begin ,E1 ,@Es) (cond ,@rest)))) ((cond . ,rest) (error "improper cond")) ((or) `#f) ((or ,E1) (expand E1)) ((or ,E1 ,E2 . ,Es) (expand (let ((v (gensym))) `(let ((,v ,E1)) (if ,v ,v (or ,E2 ,@Es)))))) ((and) `#t) ((and ,E1) (expand E1)) ((and ,E1 ,E2 . ,Es) (expand `(if ,E1 (and ,E2 ,@Es) #f))) ((,op . ,Es) when (primitive? op) `(,op ,@(map expand Es))) ((,E0 . ,Es) (map expand (cons E0 Es))) (,_ (error "unknown expression" expr)))) (define (constant? c) (match c ((quote ,x) #t) (,x (or (number? x) (string? x) (boolean? x) (char? x))))) (define primitives '(+ - * / eq? = < > <= >= null? pair? cons car cdr set-car! set-cdr! display)) (define (primitive? op) (and (symbol? op) (memq op primitives))) ;;;---------------------------------------------------------------------------- ;; Alpha-conversion. (define (alpha-conv expr) (alphac expr '())) (define (alphac expr env) (define (ac e) (alphac e env)) (define (rename v) (cond ((assq v env) => cdr) (else v))) (match expr (,c when (constant? c) expr) ((quote ,x) expr) (,v when (symbol? v) (rename v)) ((set! ,v ,E1) `(set! ,(rename v) ,(ac E1))) ((define ,v ,E1) `(define ,(rename v) ,(ac E1))) ((lambda ,params ,E) (let* ((fresh-params (map (lambda (p) (cons p (gensym))) params)) (new-env (append fresh-params env))) `(lambda ,(map cdr fresh-params) ,(alphac E new-env)))) ((let ,bindings ,E) (let* ((fresh-vars (map (lambda (b) (cons (car b) (gensym))) bindings)) (new-env (append fresh-vars env))) `(let ,(map (lambda (v e) `(,(cdr v) ,(ac (cadr e)))) fresh-vars bindings) ,(alphac E new-env)))) ((if ,E1 ,E2) `(if ,(ac E1) ,(ac E2))) ((if ,E1 ,E2 ,E3) `(if ,(ac E1) ,(ac E2) ,(ac E3))) ((,E0 . ,Es) `(,(if (primitive? E0) E0 (ac E0)) ,@(map ac Es))) (,_ (error "unknown expression" expr)))) ;;;---------------------------------------------------------------------------- ;; Assignment-conversion. (define (assign-conv expr) (let ((globals (fv expr))) (assignc expr (difference (mv expr) globals)))) (define (assignc expr mut-vars) (define (ac e) (assignc e mut-vars)) (define (mutable? v) (memq v mut-vars)) (match expr (,c when (constant? c) expr) ((quote ,x) expr) (,v when (symbol? v) (if (mutable? v) `(car ,v) v)) ((set! ,v ,E1) (if (mutable? v) `(set-car! ,v ,(ac E1)) `(set! ,v ,(ac E1)))) ((define ,v ,E1) `(define ,v ,(ac E1))) ((lambda ,params ,E) (let* ((mut-params (map (lambda (p) (cons p (gensym))) (keep mutable? params))) (params2 (map (lambda (p) (if (mutable? p) (cdr (assq p mut-params)) p)) params))) `(lambda ,params2 ,(if (null? mut-params) (ac E) `(let ,(map (lambda (x) `(,(car x) (cons ,(cdr x) '()))) mut-params) ,(ac E)))))) ((let ,bindings ,E) (let* ((vars (map car bindings)) (mut-vars (map (lambda (v) (cons v (gensym))) (keep mutable? vars))) (vars2 (map (lambda (v) (if (mutable? v) (cdr (assq v mut-vars)) v)) vars))) `(let ,(map (lambda (v e) `(,v ,(ac (cadr e)))) vars2 bindings) ,(if (null? mut-vars) (ac E) `(let ,(map (lambda (x) `(,(car x) (cons ,(cdr x) '()))) mut-vars) ,(ac E)))))) ((if ,E1 ,E2) `(if ,(ac E1) ,(ac E2))) ((if ,E1 ,E2 ,E3) `(if ,(ac E1) ,(ac E2) ,(ac E3))) ((,E0 . ,Es) `(,(if (primitive? E0) E0 (ac E0)) ,@(map ac Es))) (,_ (error "unknown expression" expr)))) ;;;---------------------------------------------------------------------------- ;; Closure-conversion. (define (closure-conv expr) (let ((globals (fv expr))) (closurec expr '() globals))) (define (closurec expr cenv globals) (define (cc e) (closurec e cenv globals)) (define (pos id) (let ((x (memq id cenv))) (and x (- (length cenv) (length x))))) (match expr (,c when (constant? c) expr) ((quote ,x) expr) (,v when (symbol? v) (let ((p (pos v))) (if p `(closure-ref $this ,p) v))) ((set! ,v ,E1) `(set! ,v ,(cc E1))) ((define ,v ,E1) `(define ,v ,(cc E1))) ((lambda ,params ,E) (let ((new-cenv (difference (fv expr) globals))) `(make-closure (lambda ($this ,@params) ,(closurec E new-cenv globals)) ,@(map cc new-cenv)))) ((let ,bindings ,E) `(let ,(map (lambda (b) `(,(car b) ,(cc (cadr b)))) bindings) ,(cc E))) ((if ,E1 ,E2) `(if ,(cc E1) ,(cc E2))) ((if ,E1 ,E2 ,E3) `(if ,(cc E1) ,(cc E2) ,(cc E3))) ((,E0 . ,Es) (if (primitive? E0) `(,E0 ,@(map cc Es)) `(let (($clo ,(cc E0))) ((closure-code $clo) $clo ,@(map cc Es))))) (,_ (error "unknown expression" expr)))) ;;;---------------------------------------------------------------------------- ;; Free-variable and mutable-variable analyses. (define (fv expr) (match expr (,c when (constant? c) '()) ((quote ,x) `()) (,v when (symbol? v) (list v)) ((set! ,v ,E1) (union (list v) (fv E1))) ((define ,v ,E1) (union (list v) (fv E1))) ((lambda ,params ,E) (difference (fv E) params)) ((let ,bindings ,E) (union (apply union (map (lambda (b) (fv (cadr b))) bindings)) (difference (fv E) (map car bindings)))) ((if ,E1 ,E2) (union (fv E1) (fv E2))) ((if ,E1 ,E2 ,E3) (union (fv E1) (fv E2) (fv E3))) ((,E0 . ,Es) (union (if (primitive? E0) '() (fv E0)) (apply union (map fv Es)))) (,_ (error "unknown expression" expr)))) (define (mv expr) (match expr (,c when (constant? c) '()) ((quote ,x) `()) (,v when (symbol? v) '()) ((set! ,v ,E1) (union (list v) (mv E1))) ((define ,v ,E1) (union (list v) (mv E1))) ((lambda ,params ,E) (mv E)) ((let ,bindings ,E) (union (apply union (map (lambda (b) (mv (cadr b))) bindings)) (mv E))) ((if ,E1 ,E2) (union (mv E1) (mv E2))) ((if ,E1 ,E2 ,E3) (union (mv E1) (mv E2) (mv E3))) ((,E0 . ,Es) (union (if (primitive? E0) '() (mv E0)) (apply union (map mv Es)))) (,_ (error "unknown expression" expr)))) ;;;---------------------------------------------------------------------------- ;; Set operations. (define (union . ss) (let loop ((lst ss) (result '())) (if (null? lst) result (loop (cdr lst) (union2 result (car lst)))))) (define (union2 s1 s2) (cond ((null? s1) s2) ((member (car s1) s2) (union2 (cdr s1) s2)) (else (cons (car s1) (union2 (cdr s1) s2))))) (define (intersect s1 s2) (cond ((null? s1) '()) ((member (car s1) s2) (cons (car s1) (intersect (cdr s1) s2))) (else (intersect (cdr s1) s2)))) (define (difference s1 s2) (cond ((null? s1) '()) ((member (car s1) s2) (difference (cdr s1) s2)) (else (cons (car s1) (difference (cdr s1) s2))))) (define (set-equal? s1 s2) (and (null? (difference s1 s2)) (null? (difference s2 s1)))) (define (keep f lst) (cond ((null? lst) '()) ((f (car lst)) (cons (car lst) (keep f (cdr lst)))) (else (keep f (cdr lst))))) ;;;---------------------------------------------------------------------------- (define (pipeline filename) (let ((source (with-input-from-file filename read-all))) (print "---------------------------- source:\n") (for-each pretty-print source) (let ((after-macro-exp (map expand source))) (print "---------------------------- after macro-expansion:\n") (for-each pretty-print after-macro-exp) (let ((after-alpha-conv (map alpha-conv after-macro-exp))) (print "---------------------------- after alpha-conversion:\n") (for-each pretty-print after-alpha-conv) (let ((after-assign-conv (map assign-conv after-alpha-conv))) (print "---------------------------- after assignment-conversion:\n") (for-each pretty-print after-assign-conv) (let ((after-closure-conv (append '((define make-closure vector) (define closure-code (lambda (clo) (vector-ref clo 0))) (define closure-ref (lambda (clo i) (vector-ref clo (+ i 1))))) (map closure-conv after-assign-conv)))) (print "---------------------------- after closure-conversion:\n") (for-each pretty-print after-closure-conv))))))) (define (main . filenames) (for-each pipeline filenames)) ===============================================================================