home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d5xx / d556 / scheme2c.lha / Scheme2C / Scheme-src.lzh / scsc / lambdacode.sc < prev    next >
Text File  |  1991-10-11  |  13KB  |  344 lines
  1. ;;; Code generator for $lambda expressions.
  2. ;;;
  3.  
  4. ;*              Copyright 1989 Digital Equipment Corporation
  5. ;*                         All Rights Reserved
  6. ;*
  7. ;* Permission to use, copy, and modify this software and its documentation is
  8. ;* hereby granted only under the following terms and conditions.  Both the
  9. ;* above copyright notice and this permission notice must appear in all copies
  10. ;* of the software, derivative works or modified versions, and any portions
  11. ;* thereof, and both notices must appear in supporting documentation.
  12. ;*
  13. ;* Users of this software agree to the terms and conditions set forth herein,
  14. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  15. ;* right and license under any changes, enhancements or extensions made to the
  16. ;* core functions of the software, including but not limited to those affording
  17. ;* compatibility with other hardware or software environments, but excluding
  18. ;* applications which incorporate this software.  Users further agree to use
  19. ;* their best efforts to return to Digital any such changes, enhancements or
  20. ;* extensions that they make and inform Digital of noteworthy uses of this
  21. ;* software.  Correspondence should be provided to Digital at:
  22. ;* 
  23. ;*                       Director of Licensing
  24. ;*                       Western Research Laboratory
  25. ;*                       Digital Equipment Corporation
  26. ;*                       100 Hamilton Avenue
  27. ;*                       Palo Alto, California  94301  
  28. ;* 
  29. ;* This software may be distributed (but not offered for sale or transferred
  30. ;* for compensation) to third parties, provided such third parties agree to
  31. ;* abide by the terms and conditions of this notice.  
  32. ;* 
  33. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  34. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  35. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  36. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  37. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  38. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  39. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  40. ;* SOFTWARE.
  41.  
  42. (module lambdacode)
  43.  
  44. ;;; External and in-line declarations.
  45.  
  46. (include "plist.sch")
  47. (include "expform.sch")
  48. (include "lambdaexp.sch")
  49. (include "miscexp.sch")
  50. (include "gencode.sch")
  51. (include "lap.sch")
  52.  
  53. ;;; ($lambda id body)  ==>  just about anything.
  54. ;;;
  55. ;;; The first part of lambda code generation is to decide whether the code is
  56. ;;; really going to be generated at this place.  If it is, then the actual
  57. ;;; code generation will be done in PROCEDURE-EMIT or CLOSED-PROCEDURE-EMIT.
  58. ;;; Functions which are identified as INLINE-TAIL will have their label
  59. ;;; allocated here.  Their code will be generated in LAMBDA-TAILS-GENC.
  60.  
  61. (define ($LAMBDA-GENC loc exp bindings)
  62.     (let* ((id       ($lambda-id exp))
  63.        (generate (lambda-generate id)))
  64.       (cond ((eq? generate 'procedure)
  65.          (procedure-emit loc id exp bindings))
  66.         ((eq? generate 'closed-procedure)
  67.          (closed-procedure-emit loc id exp bindings)))))
  68.  
  69. ;;; The most straight forward case to generate is that of a procedure which
  70. ;;; does not have a closure pointer.
  71.  
  72. (define (PROCEDURE-EMIT loc id exp bindings)
  73.     (let* ((req      (lambda-reqvars id))
  74.        (opt      (optional-args id))       
  75.        (formals  (append req (if opt (list opt) '())))
  76.        (name     (cname id))
  77.        (save-lap '())
  78.        (top      (eq? (lambda-nestin id) 'top-level)))
  79.       (if (not (eq? loc 'no-value))
  80.           (emit-lap `(SET ,(vname loc)
  81.                   ("MAKEPROCEDURE"
  82.                    ,(length req)
  83.                    ,(if opt 1 0)
  84.                    ,(cname name)
  85.                    "EMPTYLIST"))))
  86.       (set! save-lap (save-current-lap '()))
  87.       (emit-lap `(PROC ,(cname name) ,@(map vname formals)))
  88.       (emit-lap '(LIT "{"))
  89.       (emit-lap '(INDENT 8))
  90.       (emit-lap `(LOCALS DISPLAY ,free-display))
  91.       (stack-trace-emit id)
  92.       (lambda-body-genc 'return exp formals
  93.           (proc-args-to-display formals free-display) bindings)
  94.       (emit-lap `(INDENT 0))
  95.       (emit-lap '(LIT "}"))
  96.       (done-lap (save-current-lap save-lap))))
  97.  
  98. ;;; The next type of procedure to emit is one which is closed over its free
  99. ;;; variables.  The pointer to the closure will be added as the last argument
  100. ;;; to the function.
  101.  
  102. (define (CLOSED-PROCEDURE-EMIT loc id exp bindings)
  103.     (let* ((req      (lambda-reqvars id))
  104.        (opt      (optional-args id))
  105.        (closep   (newv 'close 'use 'closurep
  106.                'display (lambda-display-closep id)))
  107.        (formals  (append req
  108.                  (append (if opt (list opt) '()) (list closep))))
  109.        (name     (cname id))
  110.        (save-lap '()))
  111.       (emit-lap `(SET ,(vname loc)
  112.               ("MAKEPROCEDURE"
  113.                ,(length req)
  114.                ,(if opt 1 0)
  115.                ,(cname name)
  116.                ,(closed-proc-closure id))))
  117.       (set! save-lap (save-current-lap '()))
  118.       (emit-lap `(PROC ,(cname name) ,@(map vname formals)))
  119.       (emit-lap '(LIT "{"))
  120.       (emit-lap '(INDENT 8))
  121.       (emit-lap `(LOCALS DISPLAY ,free-display))
  122.       (stack-trace-emit id)
  123.       (let ((restore (closed-proc-display id closep)))
  124.            (if restore
  125.            (let ((temp (use-lap-temp)))
  126.             (lambda-body-genc temp exp formals
  127.                 (proc-args-to-display formals free-display)
  128.                 bindings)
  129.             (map emit-lap restore)
  130.             (emit-lap `(SET return ,(vname temp))))
  131.            (lambda-body-genc 'return exp formals formals bindings)))
  132.       (emit-lap `(INDENT 0))
  133.       (emit-lap '(LIT "}"))
  134.       (done-lap (save-current-lap save-lap))))
  135.  
  136. ;;; The following function is called to load procedure arguments into their
  137. ;;; appropriate display slots.  It will return a list of the locations holding
  138. ;;; the values to be bound to the variables, for use by lambda-body-genc.
  139.  
  140. (define (PROC-ARGS-TO-DISPLAY formals displayx)
  141.     (if formals
  142.     (let ((var (car formals)))
  143.          (if (id-display var)
  144.          (begin (emit-lap `(SET ("DISPLAY" ,displayx) ,(vname var)))
  145.             (cons `("DISPLAY" ,displayx)
  146.                   (proc-args-to-display (cdr formals)
  147.                   (+ displayx 1))))
  148.          (cons var (proc-args-to-display (cdr formals) displayx))))
  149.     '()))
  150.  
  151. ;;; The following function is called to make code for creating a closure
  152. ;;; with copies of the appropriate slots in the display.
  153.  
  154. (define (CLOSED-PROC-CLOSURE id)
  155.     (let ((lexvars (indirect-lambda-lexical id)))
  156.      (if lexvars
  157.          `("MAKECLOSURE"
  158.            "EMPTYLIST"
  159.            ,(length lexvars)
  160.            ,@(map (lambda (v) `("DISPLAY" ,(id-display v))) lexvars))
  161.          "EMPTYLIST")))
  162.  
  163. ;;; The following function emits code to save the appropriate portions of the
  164. ;;; display.  It will return code to restore the display.
  165.  
  166. (define (CLOSED-PROC-DISPLAY id closep)
  167.     (let loop ((i 0) (vars (indirect-lambda-lexical id)))
  168.      (if vars
  169.          (let ((temp (use-lap-temp))
  170.            (displayx (id-display (car vars))))
  171.           (emit-lap `(SET ,(vname temp) ("DISPLAY" ,displayx)))
  172.           (emit-lap `(SET ("DISPLAY" ,displayx)
  173.                   ("CLOSURE_VAR" ,(vname closep) ,i)))
  174.           (cons `(SET ("DISPLAY" ,displayx) ,(vname temp))
  175.             (loop (+ i 1) (cdr vars))))
  176.          '())))
  177.  
  178. ;;; Code for the stack trace-back is emitted by the following routine when
  179. ;;; SC-STACK-TRACE is true.
  180.  
  181. (define (STACK-TRACE-EMIT lid)
  182.     (if sc-stack-trace
  183.     (let ((id (lambda-name lid)))
  184.          (if (and id (eq? (id-printname id) current-define-name)
  185.               (eq? (lambda-nestin lid) 'top-level))
  186.          (emit-lap `(PUSHSTACKTRACE
  187.                 (U_TX (ADR ,(vname current-define-string)))))
  188.          (let ((temp (make-c-global))
  189.                (name (string-append
  190.                  (if id
  191.                      (symbol->string (id-printname id))
  192.                      (cname lid))
  193.                  " [inside "
  194.                  (symbol->string current-define-name)
  195.                  "]")))
  196.               (emit-global-lap
  197.               `(DEFSTRING ,(vname temp)
  198.                    (CSTRING ,name) ,(string-length name)))
  199.               (emit-lap
  200.               `(PUSHSTACKTRACE (U_TX (ADR ,(vname temp))))))))))
  201.  
  202. ;;; Code for $LAMBDA bodies is generated by the following function.  Any
  203. ;;; lambda bodies that are designated as "inline-tails" will have their
  204. ;;; lambda variables allocated and deallocated here.  Any lexical variables
  205. ;;; that they reference will also be allocated here.
  206.  
  207. (define (LAMBDA-BODY-GENC loc exp vars vals bindings)
  208.     (let* ((id ($lambda-id exp))
  209.        (save-current-code-lambda current-code-lambda)
  210.        (save-loc loc)
  211.        (save-free-display free-display)
  212.        (tails (lambda-inline-tails id)))
  213.          (set! current-code-lambda id)
  214.      (for-each
  215.          (lambda (lid)
  216.                  (for-each
  217.                  (lambda (var)
  218.                      (unless (memq var vars)
  219.                      (set! vars (append vars (list var)))
  220.                      (set! vals
  221.                            (append vals '(undefined)))))
  222.              (append (indirect-lambda-lexical lid)
  223.                  (append (lambda-reqvars lid)
  224.                      (lambda-optvars lid)))))
  225.          tails)
  226.       (if (and tails (eq? loc 'tos))
  227.           (set! loc (use-lap-temp)))
  228.       (reserve-display vars bindings)
  229.       (emit-lap `(LABEL ,(code-label id)))
  230.       (do ((bindings (lambda-bind-vars vars vals bindings))
  231.            (expl ($lambda-body exp) (cdr expl)))
  232.           ((null? expl)
  233.            (lambda-tails-genc loc exp bindings))
  234.           (if (cdr expl)
  235.           (exp-genc 'no-value (car expl) bindings)
  236.           (exp-genc loc (car expl) bindings)))
  237.       (when (not (eq? loc save-loc))
  238.         (emit-lap `(SET ,(vname save-loc) ,(vname loc)))
  239.         (drop-lap-temp loc))
  240.       (set! free-display save-free-display)
  241.       (set! current-code-lambda save-current-code-lambda)
  242.       (if tails
  243.           (intersect-with-global-condition-info
  244.            (stored-conditions-intersection tails)))))
  245.  
  246. ;;; Code for lambda expressions which are INLINE-TAIL's is generated after the
  247. ;;; code for the lambda body which they exit by this function.
  248.  
  249. (define (LAMBDA-TAILS-GENC loc exp bindings)
  250.     (let* ((id    ($lambda-id exp))
  251.        (tails (lambda-inline-tails id))
  252.        (next  (if (and tails (not (eq? loc 'return)))
  253.               (make-label)
  254.               #f))
  255.        (save-condition global-condition-info))
  256.       (do ((tails tails (cdr tails)))
  257.           ((null? tails))
  258.           (if next (emit-lap `(GOTO ,next)))
  259.           (let* ((save-temp (save-lap-temps))
  260.              (save-display free-display)
  261.              (tail (car tails))
  262.              (vars (append (lambda-reqvars tail)
  263.                    (lambda-optvars tail))))
  264.             (set! global-condition-info (retrieve-condition-info tail))
  265.             (lambda-body-genc loc (lambda-$lambda tail) vars
  266.             (map (lambda (var)
  267.                      (let ((x (id-display var)))
  268.                       (if x `("DISPLAY" ,x) var)))
  269.                  vars)    
  270.             bindings)
  271.             (store-condition-info tail)
  272.             (restore-lap-temps save-temp)
  273.             (set! free-display save-display)))
  274.       (if next (emit-lap `(LABEL ,next)))
  275.       (set! global-condition-info save-condition)))
  276.  
  277. ;;; The following function is called to allocate variables to the display.
  278.  
  279. (define (RESERVE-DISPLAY vars bindings)
  280.     (let loop ((vars vars))
  281.      (if vars
  282.          (let ((var (car vars)))
  283.           (if (and (id-display var) (not (memq var bindings)))
  284.               (let ((displayx (let ((x free-display))
  285.                        (set! free-display
  286.                          (+ free-display 1))
  287.                        x)))
  288.                (set-id-display! var displayx)))
  289.           (loop (cdr vars)))
  290.          (begin (set! lap-max-display (max lap-max-display free-display))
  291.             (set! max-display (max max-display free-display))))))
  292.  
  293. ;;; Variables are bound by calling the following function with the variables,
  294. ;;; the cells holding their initial values, and the current bindings.  It
  295. ;;; will return the new bindings, which is a list of variables which are
  296. ;;; currently bound to the value held in either a display slot or a temporary.
  297.  
  298. (define (LAMBDA-BIND-VARS vars vals bindings)
  299.     (do ((vars      vars (cdr vars))
  300.      (vals      vals (cdr vals))
  301.      (bindings  bindings (if (memq (car vars) bindings)
  302.                  bindings
  303.                  (cons (car vars) bindings))))
  304.     ((null? vals) bindings)
  305.     (let ((var (car vars))
  306.           (val (car vals)))
  307.          (cond ((and (eq? val 'undefined) (memq var bindings)))
  308.            ((id-display var)
  309.             (cond ((eq? val 'undefined))
  310.               ((id-set! var)
  311.                (emit-lap `(SET ("DISPLAY" ,(id-display var))
  312.                        (CONS ,(vname val) "EMPTYLIST"))))
  313.               ((not (equal? val `("DISPLAY" ,(id-display var))))
  314.                (emit-lap `(SET ("DISPLAY" ,(id-display var))
  315.                        ,(vname val))))))
  316.            ((and (id-set! var)
  317.              (or (not (id-lambda var))
  318.                  (eq? (lambda-generate (id-lambda var))
  319.                   'closed-procedure)))
  320.             (cond ((eq? val 'undefined)
  321.                (set-id-vname! var (use-lap-temp)))
  322.               ((memq var bindings)
  323.                (emit-lap `(SET ,(vname var)
  324.                        ("CONS" ,(vname val)
  325.                         "EMPTYLIST"))))
  326.               (else
  327.                (let ((vn (id-vname
  328.                      (if (eq? var val)
  329.                          val
  330.                          (use-lap-temp)))))
  331.                 (emit-lap `(SET ,vn
  332.                         ("CONS" ,(vname val)
  333.                          "EMPTYLIST")))
  334.                 (set-id-vname! var vn)))))
  335.            ((eq? val 'undefined)
  336.             (if (or (not (id-lambda var))
  337.                 (eq? (lambda-generate (id-lambda var))
  338.                  'closed-procedure))
  339.             (set-id-vname! var (use-lap-temp))))
  340.            ((not (eq? var val))
  341.             (if (not (memq var bindings))
  342.             (set-id-vname! var (use-lap-temp)))
  343.             (emit-lap `(SET ,(vname var) ,(vname val))))))))
  344.