home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / comex.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  9.2 KB  |  236 lines
  1. (herald (back_end comex)
  2.   (env t (orbit_top defs) (back_end closure)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define (get-template-definer l)
  30.   (iterate loop ((l l))
  31.    (let ((node (node-parent l)))
  32.     (cond ((not node) 0)
  33.           ((and (eq? (lambda-strategy l) strategy/heap)
  34.                 (continuation? l))
  35.            0)
  36.           ((or (primop-ref? (call-proc node) primop/*define)
  37.            (primop-ref? (call-proc node) primop/*lset))
  38.            (let ((offset (cdr (ass (lambda (x y)
  39.                                  (and (loc-list? y)
  40.                                       (eq? x (loc-list-var y))))
  41.                               (leaf-value ((call-arg 2) node))
  42.                               (closure-env *unit*)))))
  43.              (fx/ offset 4)))
  44.           (else 
  45.            (loop (node-parent node)))))))
  46.  
  47. (define-structure-type lap-template-struct
  48.   pointer
  49.   nargs
  50.   handler-tag
  51.   strategy
  52.   instructions)
  53.  
  54.  
  55. (define (generate-lap-template node)
  56.   (destructure (((#f i-node) (call-args node)))
  57.     (let ((tem (make-lap-template-struct))
  58.           (i-stream (leaf-value i-node)))
  59.       (destructure (((pointer nargs nary? strategy tag) (car i-stream)))
  60.         (set (lap-template-struct-pointer tem) (eval pointer orbit-env)) ; arghh
  61.         (set (lap-template-struct-nargs tem) (cons nargs nary?))
  62.         (set (lap-template-struct-strategy tem)
  63.              (if (eq? strategy 'stack) 0 1))
  64.         (set (lap-template-struct-handler-tag tem) tag)
  65.         (set (lap-template-struct-instructions tem) (cdr i-stream))
  66.         (lambda-queue tem)
  67.         (free-register node AN)    ; where set (define) code expects
  68.         (generate-move-pcrel tem AN)
  69.         (mark-continuation node AN)))))
  70.  
  71. (define (process-lap-template tem)
  72.   (emit-template tem (lap-template-struct-handler-tag tem))
  73.   (set *lambda* (car (find (lambda (pair) (lambda-node? (car pair)))
  74.                            (closure-env *unit*))))
  75.   (lap-transduce (lap-template-struct-instructions tem))
  76.   (process-lambda-queue))                                                                                
  77.  
  78. (define (create-comex filename h unit templates thing code)
  79.   (let ((size (fx+ (fx+ (length unit) 4) (fx* (length templates) 2))) ; hack,
  80.         (comex (make-comex)))                                         ; template
  81.     (receive (objects opcodes)                                        ; in both
  82.              (create-obj-op-vectors thing unit size filename h)
  83.       (set (comex-module-name comex) version-number)
  84.       (set (comex-code comex) code)
  85.       (set (comex-objects comex) objects)
  86.       (set (comex-opcodes comex) opcodes)           
  87.       (set (comex-annotation comex) nil)
  88.       comex)))
  89.  
  90. (define (create-obj-op-vectors thing unit size filename h)
  91.   (let ((objects (make-vector size))
  92.         (opcodes (make-bytev size)))
  93.     (set (bref opcodes 0) op/literal)                         
  94.     (vset objects 0 (->compiler-filename filename))
  95.     (set (bref opcodes 1) op/literal)                         
  96.     (vset objects 1 h)                       
  97.     (set (bref opcodes 2) op/literal)                         
  98.     (vset objects 2 'unit-env)                  
  99.     (set (bref opcodes 3) op/closure)
  100.     (vset objects 3 (code-vector-offset thing))
  101.     (iterate loop ((a-list unit) (i 4))         
  102.       (cond ((null? a-list)
  103.              (return objects opcodes))
  104.             ((closure? (caar a-list))
  105.              (vset objects i
  106.                    (code-vector-offset (cit->lambda (caar a-list))))
  107.              (set (bref opcodes i) op/template1)
  108.              (set (bref opcodes (fx+ i 1)) op/template2)
  109.              (set (bref opcodes (fx+ i 2)) op/template3)
  110.              (loop (cdr a-list) (fx+ i 3)))
  111.             (else
  112.              (receive (opcode obj) (comex-decipher (caar a-list))
  113.                (vset objects i obj)
  114.                (set (bref opcodes i) opcode)
  115.                (loop (cdr a-list) (fx+ i 1))))))))
  116.  
  117.  
  118. (define (->compiler-filename fn)
  119.   (list (cond ((filename-fs fn))
  120.               (else (fs-name (local-fs))))
  121.         (filename-dir fn)
  122.         (filename-name fn)
  123.         (cond ((filename-type fn))
  124.               (else 't))))
  125.  
  126.  
  127.  
  128.  
  129. (define (comex-decipher obj)
  130.   (cond ((foreign-name obj)
  131.          => (lambda (name) (return op/foreign name)))
  132.         ((and (node? obj) (lambda-node? obj))
  133.          (return op/closure (code-vector-offset obj)))
  134.         ((loc-list? obj)
  135.          (vcell-status (loc-list-var obj)))
  136.         ((not (variable? obj))
  137.          (return op/literal obj))
  138.         (else
  139.          (return op/variable-value (variable-name obj)))))
  140.  
  141. (define (vcell-status var)
  142.   (let ((name (variable-name var)))
  143.     (cond ((not (defined-variable? var))
  144.        (return op/vcell name))
  145.       (else
  146.        (case (defined-variable-variant var)
  147.          ((set) (return op/vcell name))
  148.          ((lset) (return op/vcell-lset name))
  149.          (else
  150.           (let ((l (defined-variable-value var)))
  151.         (cond ((and l
  152.                 (let ((node ((call-arg 3) (node-parent l))))
  153.                   (and (lambda-node? node)
  154.                    (assq node (closure-env *unit*)))))
  155.                => (lambda (pair)
  156.                 (return op/vcell-stored-definition
  157.                     (cons name (cdr pair)))))
  158.               (else
  159.                (return op/vcell-defined name))))))))))
  160.  
  161. (define (cit->lambda closure)
  162.   (variable-binder (car (closure-members closure))))
  163.  
  164. (define (static var-name)
  165.   (let* ((a-list (closure-env *unit*))
  166.          (val (ass (lambda (name var)
  167.                      (and (loc-list? var)
  168.               (eq? (variable-name (loc-list-var var)) name)))
  169.                    var-name
  170.                    a-list)))
  171.     (cond (val
  172.            (fx- (cdr val)
  173.                 (fx+ (cond ((assq *lambda* (cddr a-list))
  174.                             => cdr)
  175.                            (else
  176.                             (cdr (last a-list))))
  177.                       tag/extend)))
  178.           (else
  179.            (error "static value not mentioned ~s" var-name)))))
  180.  
  181.  
  182. (define (template-nary l)
  183.   (xcond ((lambda-node? l)                             
  184.           (cond ((object-lambda? l)
  185.                  (lambda-rest-var ((call-arg 2) (lambda-body l))))
  186.                 (else       
  187.                  (or (eq? (lambda-strategy l) strategy/vframe)
  188.                      (eq? (lambda-strategy l) strategy/ezclose)
  189.                      (lambda-rest-var l)))))
  190.          ((lap-template-struct? l)
  191.           (cdr (lap-template-struct-nargs l)))))
  192.  
  193.  
  194. (define (get-template-annotation l)
  195.   (xcond ((lambda-node? l)
  196. (fx+ (fixnum-ashl (get-template-definer l) 3)
  197.      (fx+ (fixnum-ashl (if (eq? (lambda-strategy l) strategy/stack) 0 1) 1)
  198.           (if (and (eq? (lambda-strategy l) strategy/heap)
  199.            (environment? (lambda-env l))
  200.            (fxn= (environment-cic-offset (lambda-env l)) 0))
  201.           1
  202.           0))))
  203.          ((lap-template-struct? l)
  204.      (fixnum-ashl (lap-template-struct-strategy l) 1))))
  205.  
  206.           
  207. (define (get-template-cells l)
  208.   (cond ((lap-template-struct? l)
  209.          (lap-template-struct-pointer l))
  210.     ((environment? (lambda-env l))
  211.      (let ((offset (environment-cic-offset (lambda-env l))))
  212.        (cond ((fxn= offset 0) offset)
  213.          (else
  214.           (let ((closure (environment-closure (lambda-env l))))
  215.             (closure-pointer closure))))))
  216.     (else 0)))
  217.           
  218.  
  219. (define (get-template-nargs l)
  220.   (xcond ((lambda-node? l)
  221.           (select (lambda-strategy l)
  222.             ((strategy/stack)
  223.              (fx- 0 (fx+ (length (lambda-variables l)) 1)))
  224.             ((strategy/vframe strategy/ezclose) -1)
  225.             (else
  226.              (cond ((object-lambda? l)
  227.                     (let ((proc ((call-arg 2) (lambda-body l))))
  228.                       (if (primop-ref? (call-proc (lambda-body proc))
  229.                                        primop/undefined-effect)
  230.                           1
  231.                           (length (lambda-variables proc)))))     
  232.                    (else
  233.                     (length (lambda-variables l)))))))
  234.          ((lap-template-struct? l)
  235.           (car (lap-template-struct-nargs l)))))
  236.