; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING. ; This is a backquote-like macro for building nodes. ; ; One goal is to produce code that is as efficient as possible. ; ; (LET-NODES ( ... ) . ) ; ; ::= (

) | ; call node ; ( ( ... ) ) | ; lambda node ; ( ( ... . ) ) ; lambda node ; ; ::= #f | Ignored variable position ; | Evaluate and copy it, rebinding ; ' | Evaluate to get the variable ; ( ) (MAKE-VARIABLE ) ; ; ::= ; ; ::= | ; ; ::= ( . ) ; ; ::= ( ... ) | ( ... . ) ; ; ::= ; ; ::= 'foo literal node containing the value of foo, no rep ; '(foo rep) " " " " " " " , using rep ; (* foo) reference to foo (which evaluates to a variable) ; (! foo) foo evaluates to a node ; foo short for (! foo) when foo is an atom ; #f put nothing here ; ( . ) a nested call ;-------------------------------------- ; ; Example: ; ; (let-nodes ((c1 (l1 1 cont)) ; (l1 ((j type/pointer)) (proc 2 l2 l3 . rest)) ; (l2 () ((jump cont (* j)) '(true-value type/boolean))) ; (l3 () ((jump cont (* j)) '(false-value type/boolean)))) ; (replace-body node c1)) ; ; ==> ; ; (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER))) ; (LET ((C1 (CREATE-CALL-NODE '2 1)) ; (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2)) ; (L1 (CREATE-LAMBDA-NODE 'C 'CONT (FLIST1 J '()))) ; (C.1224 (CREATE-CALL-NODE '4 0)) ; (L2 (CREATE-LAMBDA-NODE 'C 'CONT '())) ; (C.1223 (CREATE-CALL-NODE '4 0)) ; (L3 (CREATE-LAMBDA-NODE 'C 'CONT '()))) ; (ATTACH 0 C1 L1) ; (ATTACH 1 C1 CONT) ; (ATTACH 0 C.1225 PROC) ; (ATTACH-CALL-ARGS C.1225 (APPEND (LIST L2 L3) REST)) ; (ATTACH-BODY L1 C.1225) ; (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP)) ; (ATTACH-THREE-CALL-ARGS C.1224 ; (CREATE-JUMP-MARKER CONT) ; (CREATE-REFERENCE-NODE J) ; (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN)) ; (ATTACH-BODY L2 C.1224) ; (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP)) ; (ATTACH-THREE-CALL-ARGS C.1223 ; (CREATE-JUMP-MARKER CONT) ; (CREATE-REFERENCE-NODE J) ; (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN)) ; (ATTACH-BODY L3 C.1223) ; (REPLACE-BODY NODE C1))) ; (define (expand-let-nodes form rename compare) (destructure (((#f specs . body) form)) (receive (vars nodes code) (parse-node-specs specs rename compare) `(,(rename 'let) ,vars (,(rename 'let) ,nodes ,@code ,@body))))) (define (test form) (destructure (((#f specs . body) form)) (receive (vars nodes code) (parse-node-specs specs identity eq?) `(let ,vars (let ,nodes ,@code ,@body))))) ; Parse the specs, returning a list of variable specs, a list of node specs, ; and a list of construction forms. An input spec is either a call or a ; lambda, each is parsed by an appropriate procedure. (define (parse-node-specs specs r c) (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '())) (if (null? specs) (values vars nodes codes) (destructure ((((name . spec) . rest) specs)) (cond ((null? (cdr spec)) (receive (node code) (construct-call name (car spec) r c) (loop rest vars `((,name ,node) . ,nodes) (append code codes)))) ((= 2 (length spec)) (receive (vs node new-spec call) (construct-lambda (car spec) (cadr spec) r c) (loop (if new-spec (cons new-spec rest) rest) (append vs vars) `((,name ,node) . ,nodes) (if call `((attach-body ,name ,call) . ,codes) codes)))) (else (error "illegal spec in LET-NODES ~S" (cons name spec)))))))) ; The names of the call-arg relation procedures, indexed by the number of ; arguments handled. (define call-attach-names '#(#f #f attach-two-call-args attach-three-call-args attach-four-call-args attach-five-call-args)) ; Return the node spec and construction forms for a call. This dispatches ; on whether the argument list is proper or not. ; ; ::= ( ... ) | ; ( ... . )) ; ((JUMP l-node value) ... ) ; ((JUMP l-node value) ... . ) (define (construct-call name specs r c) (destructure (((proc . args) specs)) (really-construct-call name proc (car args) '() (cdr args) r c))) (define (construct-nested-call specs r c) (destructure (((primop-id . args) specs)) (let ((name (r 'call))) (receive (node code) (really-construct-call name primop-id 0 '() args r c) `(,(r 'let) ((,name ,node)) ,@code ,name))))) (define (really-construct-call name primop-id exits extra args r c) (receive (arg-count arg-code) (parse-call-args name extra args r c) (let ((primop-code (get-primop-code primop-id r))) (values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits) arg-code)))) (define (get-primop-code id r) (cond ((name->enumerand id primop) => (lambda (n) `(,(r 'get-primop) ,n))) (else `(,(r 'lookup-primop) ',id)))) ; NAME = the call node which gets the arguments ; EXTRA = initial, already expanded arguments ; ARGS = unexpanded arguments ; LAST-ARG = an atom whose value is added to the end of the arguments ; Returns ARG-COUNT-CODE and ARG-CODE (define (parse-call-args name extra args r c) (receive (args last-arg) (decouple-improper-list args) (let* ((args (append extra (map (lambda (a) (construct-node a r c)) args))) (count (length args))) (if (not (null? last-arg)) (values `(,(r '+) ,count (,(r 'length) ,last-arg)) `((,(r 'attach-call-args) ,name ,(if (null? args) last-arg `(,(r 'append) (,(r 'list) . ,args) ,last-arg))))) (values count (cond ((= count 0) '()) ((and (= count 1) (car args)) `((,(r 'attach) ,name 0 ,(car args)))) ((and (< count 6) (every? identity args)) `((,(r (vector-ref call-attach-names count)) ,name ,@args))) (else `((,(r 'attach-call-args) ,name (list . ,args)))))))))) ; Return proper part of the list and its last-cdr separately. (define (decouple-improper-list list) (do ((list list (cdr list)) (res '() (cons (car list) res))) ((atom? list) (values (reverse! res) list)))) ; Dispatch on the type of the SPEC and return the appropriate code. ; ; ::= 'foo literal node containing the value of foo, no rep ; '(foo rep) literal node containing the value of foo ; (* foo) reference to foo (which evaluates to a variable) ; (! foo) foo evaluates to a node ; name short for (! name) when foo is an atom (define (construct-node spec r c) (cond ((atom? spec) spec) (else (destructure (((key data) spec)) (case key ((*) `(,(r 'make-reference-node) ,data)) ((quote) (if (pair? data) `(,(r 'make-literal-node) . ,data) `(,(r 'make-literal-node) ,data type/unknown))) ((!) data) (else (construct-nested-call spec r c))))))) ; Parse a lambda spec. This returns a list of variable specs, code to ; construct the lambda node, a spec for the body if necessary, and ; the code needed to put it all together. (define (construct-lambda vars call r c) (receive (vars node) (construct-vars vars r c) (cond ((null? call) (values vars node #f #f)) ((atom? call) (values vars node #f call)) (else (let ((sym (r (generate-symbol 'c)))) (values vars node `(,sym ,call) sym)))))) ; Returns the code needed to construct the variables and the code to make ; the lambda node that binds the variables. ; ; ::= #f | Ignored variable position ; | Evaluate and copy it, rebinding ; ' | Evaluate to get the variable ; ( ) (MAKE-VARIABLE ) (define (construct-vars vars r c) (let loop ((vs vars) (vlist '()) (code '())) (cond ((atom? vs) (let ((vars (if (null? vs) `(,(r 'list) . ,(reverse! vlist)) `(,(r 'append) (,(r 'list) . ,(reverse! vlist)) ,vs)))) (values code `(,(r 'make-lambda-node) 'c 'cont ,vars)))) (else (let ((spec (car vs)) (rest (cdr vs))) (cond ((null? spec) (loop rest (cons #f vlist) code)) ((atom? spec) (loop rest (cons spec vlist) `((,spec (,(r 'copy-variable) ,spec)) . ,code))) ((c (car spec) 'quote) (loop rest (cons (cadr spec) vlist) code)) (else (loop rest (cons (car spec) vlist) `((,(car spec) (,(r 'make-variable) ',(car spec) ,(cadr spec))) . ,code))))))))) ;------------------------------------------------------------------------------ ; GENSYM utility (define *generate-symbol-index* 0) (define (generate-symbol sym) (let ((i *generate-symbol-index*)) (set! *generate-symbol-index* (+ i 1)) (concatenate-symbol sym "." i)))