home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / assembler / riscas.t < prev    next >
Encoding:
Text File  |  1990-10-16  |  9.9 KB  |  355 lines
  1. (herald as)
  2.  
  3. ;;; $4 -> (lit . 4)
  4. ;;; 3(r4) -> (4 . 3)
  5. ;;; label -> label
  6. ;;; (r4,r5) -> ((4 . 5))
  7.  
  8. (define-constant jump-op/jabs 0)
  9. (define-constant jump-op/jn=  1) (define-constant jump-op/j=   -1)
  10. (define-constant jump-op/j>   2) (define-constant jump-op/j<=  -2)
  11. (define-constant jump-op/j>=  3) (define-constant jump-op/j<   -3)
  12. (define-constant jump-op/uj>  4) (define-constant jump-op/uj<= -4) 
  13. (define-constant jump-op/uj>= 5) (define-constant jump-op/uj<  -5)
  14. (define-constant jump-op/not_negative 6) (define-constant jump-op/negative -6)
  15. (define-constant jump-op/no_overflow  7) (define-constant jump-op/overflow -7) 
  16. (define-constant jump-op/jl 8)                                                                   
  17.  
  18. (define (reverse-jump-ops j)
  19.   (select j
  20.     ((jump-op/j<) jump-op/j>)
  21.     ((jump-op/j>) jump-op/j<)
  22.     ((jump-op/j<=) jump-op/j>=)
  23.     ((jump-op/j>=) jump-op/j<=)
  24.     ((jump-op/uj<) jump-op/uj>)
  25.     ((jump-op/uj>) jump-op/uj<)
  26.     ((jump-op/uj<=) jump-op/uj>=)
  27.     ((jump-op/uj>=) jump-op/uj<=)
  28.     (else j)))
  29.  
  30. (define-operation (read-registers . args) (ignore args) (return zero zero))
  31. (define-operation (write-register . args) (ignore args) zero)
  32.  
  33. (define-structure-type ib
  34.   address
  35.   node
  36.   instructions
  37.   1next
  38.   0next
  39.   cc
  40.   avoid-jump?
  41.   previous
  42. (((pretty-print self port)
  43.   (pretty-print (ib-instructions self) port))))
  44.  
  45. (let ((m (stype-master ib-stype)))
  46.   (set (ib-instructions m) nil)
  47.   (set (ib-1next m) nil)
  48.   (set (ib-0next m) nil)
  49.   (set (ib-avoid-jump? m) nil)
  50.   (set (ib-previous m) nil)
  51.   (set (ib-cc m) nil)
  52.   (set (ib-address m) nil))
  53.  
  54. (lset *current-ib* nil)
  55. (lset *cal* nil)
  56. (lset *bits* nil)
  57. (lset *is* nil)
  58. (lset *template-ibs* nil)
  59. (lset *useless-ibs* nil)
  60. (lset *current-comment* nil)
  61. (lset *assembly-comments?* nil)
  62. (lset *assembler-retains-pointers?* nil)
  63. (lset *template-descriptors* nil)
  64.  
  65. (define (assemble-init c)
  66.   (cond (*assembler-retains-pointers?*
  67.      (set *current-ib* (make-ib))
  68.      (set *cal* (make-table 'assembly-labels))
  69.      (set *bits* nil)
  70.      (set *is* nil)
  71.      (set *template-ibs* nil)
  72.      (set *useless-ibs* nil)
  73.      (set *current-comment* nil)
  74.      (set (ib-node *current-ib*) nil)
  75.      (set *template-descriptors* (make-table '*template-descriptors*))
  76.      (c))
  77.     (else
  78.      (bind ((*current-ib* (make-ib))
  79.         (*cal* (make-table 'assembly-labels))
  80.         (*bits* nil)
  81.         (*is* nil)
  82.         (*template-ibs* nil)
  83.         (*useless-ibs* nil)
  84.         (*template-descriptors* (make-table '*template-descriptors*))
  85.         (*current-comment* nil))
  86.            (set (ib-node *current-ib*) nil)
  87.        (c)))))
  88.  
  89. (define (as-debug)
  90.   (set *assembly-comments?* t)
  91.   (set *assembler-retains-pointers?* t))
  92.  
  93. (define (as-undebug)
  94.   (set *assembly-comments?* nil)
  95.   (set *is* nil)
  96.   (set *bits* nil)
  97.   (set *assembler-retains-pointers?* nil))
  98.  
  99. (define (code-vector-offset thing)
  100.   (fx+ (ib-address (table-entry *cal* thing)) *offset-from-template*))
  101.  
  102. (define (assemble)
  103.   (modify (ib-instructions *current-ib*) reverse!)
  104.   (push *template-ibs* *current-ib*)
  105.   (remove-useless-blocks)
  106.   (iterate loop ((ibs (reverse! *template-ibs*)) (i 0) (is '()))
  107.     (cond ((null? ibs)
  108.        (let* ((code (assemble-bits i (reverse! is)))
  109.           (debugex (->debugex *template-descriptors*)))
  110.          (return code debugex)))
  111.       (else
  112.        (add-to-front (car ibs))
  113.        (receive (i is) (linearize-code-blocks i is)
  114.          (loop (cdr ibs) i is))))))
  115.  
  116. (define (->debugex thing)
  117.   (let ((a-list '()))
  118.     (walk-table (lambda (key value)
  119.           (ignore key)
  120.           (push a-list value))
  121.         thing)
  122.     a-list))
  123.  
  124.      
  125. (define-operation (instruction-as-string . args) "")
  126.  
  127.  
  128. (define (listing) (assembly-list *is* *bits*))
  129.  
  130. (define quicklist listing)
  131.  
  132. (define (cons-an-ib thing)
  133.   (let ((ib (make-ib)))
  134.     (set (table-entry *cal* thing) ib)
  135.     (set (ib-node ib) thing)
  136.     ib))
  137.  
  138. (define (maybe-cons-an-ib thing)
  139.   (or (table-entry *cal* thing)
  140.       (cons-an-ib thing)))
  141.  
  142.  
  143. (define (emit-comment string . args)
  144.   (set *current-comment* (cons string args)))
  145.  
  146. (define (emit-template l h)
  147.   (if (and (node? l) 
  148.        (environment? (lambda-env l))
  149.        (fx= (environment-cic-offset (lambda-env l)) 0))
  150.       (emit-template-descriptor l 
  151.                 (compute-environment (environment-closure (lambda-env l)))
  152.                 (get-source-code-heap l)))
  153.   (emit-tag l)
  154.   (cond ((neq? l h)
  155.      (let ((h (maybe-cons-an-ib h)))
  156.        (push *template-ibs* h)
  157.        (push (ib-instructions *current-ib*) `(,template1 () ,l ,h))))
  158.     (else
  159.      (push (ib-instructions *current-ib*) `(,template1 () ,l ,nil))))
  160.   (push (ib-instructions *current-ib*) `(,template2 () ,l))
  161.   (push (ib-instructions *current-ib*) `(,template3 ,*current-comment* ,l))
  162.   (set *current-comment* nil))
  163.  
  164. (define (compute-environment closure)
  165.   (let ((members (closure-members closure)))
  166.     (iterate loop ((pairs (closure-env closure)) (a-list '()) (next nil))
  167.       (cond ((null? pairs) (if next (cons next a-list) a-list))
  168.         (else
  169.          (let ((var (caar pairs))
  170.            (offset (fixnum-ashr (fx- (cdar pairs) 4) 2)))
  171.            (cond ((memq? (caar pairs) members)
  172.               (loop (cdr pairs) a-list next))
  173.              ((fxn= (variable-number var) 0)
  174.               (if (neq? (variable-name var) 'v)
  175.               (loop (cdr pairs) 
  176.                 (cons (cons (variable-name var) offset)
  177.                       a-list)
  178.                 next)
  179.               (loop (cdr pairs) a-list next)))
  180.              ((assq (variable-binder var) (closure-env *unit*))
  181.               (loop (cdr pairs) a-list next))
  182.              (next
  183.               (loop (cdr pairs) a-list next))
  184.              (else
  185.               (loop (cdr pairs)
  186.                 a-list
  187.                 (cons '#t offset))))))))))
  188.  
  189.  
  190. (define (emit-bogus-stack-template)
  191.   (really-emit-stack-template nil))
  192.  
  193. (define (emit-stack-template l saved)
  194.   (let ((a-list 
  195.      (iterate loop ((pairs saved) (a-list '()) (next nil))
  196.        (cond ((null? pairs) 
  197.           (if next (cons next a-list) a-list))
  198.          (else
  199.           (let ((var (caar pairs))
  200.             (offset (fx- (cdar pairs) *first-stack-register*)))
  201.             (cond ((fxn= (variable-number var) 0)
  202.                (if (neq? (variable-name var) 'v)
  203.                    (loop (cdr pairs)
  204.                      (cons (cons (variable-name var) offset)
  205.                        a-list)
  206.                      next)
  207.                    (loop (cdr pairs) a-list next)))
  208.               ((assq (variable-binder var) (closure-env *unit*))
  209.                (loop (cdr pairs) a-list next))
  210.               (next
  211.                (loop (cdr pairs) a-list next))
  212.               (else
  213.                (loop (cdr pairs)
  214.                  a-list
  215.                  (cons '#t offset))))))))))
  216.     (emit-template-descriptor l a-list (get-source-code-stack l)))
  217.   (really-emit-stack-template l))
  218.  
  219.  
  220. (define (really-emit-stack-template l)
  221.   (push (ib-instructions *current-ib*) `(,stemplate1 () ,l))
  222.   (push (ib-instructions *current-ib*) `(,template2 () ,l))
  223.   (push (ib-instructions *current-ib*)
  224.     `(,stemplate3 ,*current-comment* ,l ,*lambda*))
  225.   (set *current-comment* nil))
  226.  
  227. (define (emit-template-descriptor l env source)
  228.   (set (table-entry *template-descriptors* l) 
  229.        (cons nil (cons env source))))
  230.  
  231. (define (get-source-code-stack l)
  232.   (iterate loop ((call (node-parent l)))
  233.     (cond ((not call) '())
  234.       ((call-source call) => dumpable-source!)
  235.       (else
  236.        (loop (node-parent (node-parent call)))))))
  237.  
  238. (define (dumpable-source! exp)
  239.   (if (atom? exp)
  240.       (cond ((syntax-descriptor? exp) (identification exp))
  241.         ((primop? exp) (any-primop-id exp))
  242.         ((node? exp) '??)
  243.         (else exp))
  244.       (iterate dumpable-source! ((exp exp))
  245.         (let ((a (car exp)))
  246.       (cond ((pair? a) (dumpable-source! a))
  247.         ((syntax-descriptor? a) 
  248.          (set (car exp) (identification a)))
  249.         ((primop? a) 
  250.          (set (car exp) (any-primop-id a)))
  251.         ((node? a) 
  252.          (set (car exp) '??))))
  253.     (let ((d (cdr exp)))
  254.       (cond ((pair? d) (dumpable-source! d))
  255.         ((syntax-descriptor? d) 
  256.          (set (cdr exp) (identification d)))
  257.         ((primop? d) 
  258.          (set (cdr exp) (any-primop-id d)))
  259.         ((node? d) 
  260.          (set (cdr exp) '??))))
  261.     exp)))
  262.  
  263.  
  264. (define (get-source-code-heap l) '())
  265.  
  266.  
  267. (define (emit-tag l)
  268.   (if (and (null? (ib-instructions *current-ib*))
  269.        (let ((node (ib-node *current-ib*)))
  270.          (or (not (node? node))
  271.          (not (lambda-node? node))
  272.          (neq? (lambda-strategy node) strategy/open)))
  273.        (not (ib-0next *current-ib*)))
  274.       (push *useless-ibs* *current-ib*)
  275.       (push *template-ibs* *current-ib*))
  276.   (modify (ib-instructions *current-ib*) reverse!)
  277.   (set *current-ib* (maybe-cons-an-ib l)))
  278.  
  279. (define (address-of x)
  280.   (xcond ((ib? x) (ib-address x))
  281.          ((symbol? x) (table-entry *cal* x))))
  282.  
  283. (define (label l) (cons (if (eq? (lambda-strategy l) strategy/heap)
  284.                 'template
  285.                 'label)
  286.             (maybe-cons-an-ib l)))
  287.  
  288. (define (asemit op args)
  289.   (push (ib-instructions *current-ib*) (cons op (cons *current-comment* args)))
  290.   (set *current-comment* nil))
  291.  
  292. (define (tp-offset thing)
  293.   `(tp-offset . ,(maybe-cons-an-ib thing)))
  294.  
  295. (define (label-offset thing)
  296.   `(label-offset . ,(maybe-cons-an-ib thing)))
  297.  
  298. (define (handler-diff method obj)
  299.   `(handler-diff . (,(maybe-cons-an-ib method) . ,(maybe-cons-an-ib obj))))
  300.  
  301. (define (remove-useless-blocks)
  302.   (walk remove-useless-block *useless-ibs*))
  303.   
  304.  
  305. (define (remove-useless-block ib)
  306.   (let ((next (ib-1next ib)))
  307.     (walk (lambda (p)
  308.         (push (ib-previous next) p)
  309.         (if (eq? (ib-1next p) ib)
  310.         (set (ib-1next p) next)
  311.         (set (ib-0next p) next)))
  312.       (ib-previous ib))))
  313.       
  314. (lset *blocks-pending* '())
  315.  
  316.  
  317.  
  318.  
  319.  
  320. (define (lapemit op . args)
  321.   (asemit op args))
  322.  
  323. (define (lap-transduce is)
  324.   (walk (lambda (inst)
  325.       (cond ((atom? inst)
  326.          (or (ib-cc *current-ib*) (emit-jump inst))
  327.          (emit-tag inst))
  328.         ((table-entry lap-pseudo-ops (car inst))
  329.          => (lambda (proc) (apply proc (cdr inst))))
  330.         ((table-entry lap-instructions (car inst))
  331.          => (lambda (proc)
  332.               (apply emit proc (map! lap-eval (cdr inst)))))
  333.         (else (error "Bad lap ~s" inst))))
  334.     is))
  335.  
  336. (define (lap-eval x)
  337.   (cond ((atom? x)
  338.      (*value orbit-env x))
  339.     (else
  340.      (case (car x)
  341.        (($)
  342.         (cons 'lit (eval (cadr x) orbit-env)))
  343.        ((d@r)
  344.         (list 'reg-offset (lap-eval (cadr x))
  345.           (let ((x (caddr x)))
  346.             (cond ((and (pair? x) (eq? (car x) 'static))
  347.                (static (cadr x)))
  348.               (else (eval x orbit-env))))))
  349.        ((d@nil) (list 'reg-offset nil-reg (eval (cadr x) orbit-env)))
  350.        (else (error "Bad lap operand ~s" x))))))
  351.  
  352. (define lap-table (make-table 'lap-table))
  353. (define (define-lap x y)
  354.   (set (table-entry lap-table x) y))
  355.