home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / back / bittop.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  17.4 KB  |  550 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: bittop.scm,v 1.22 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Assembler Top Level
  23. ;;; package: (compiler assembler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define *equates*)
  28. (define *objects*)
  29. (define *entry-points*)
  30. (define *the-symbol-table*)
  31. (define *start-label*)
  32. (define *end-label*)
  33.  
  34. ;;;; Assembler top level procedure
  35.  
  36. (define (assemble start-label instructions)
  37.   (fluid-let ((*equates* (make-queue))
  38.           (*objects* (make-queue))
  39.           (*entry-points* (make-queue))
  40.           (*the-symbol-table* (make-symbol-table))
  41.           (*start-label* start-label)
  42.           (*end-label* (generate-uninterned-symbol 'END-LABEL-)))
  43.     (initialize-symbol-table!)
  44.     (call-with-values
  45.     (lambda ()
  46.       (initial-phase
  47.        (if (null? instructions)
  48.            '()
  49.            (let ((holder (list 'HOLDER)))
  50.          (let loop ((tail holder)
  51.                 (instructions
  52.                  (let ((i instructions))
  53.                    (set! instructions)
  54.                    i)))
  55.            (if (not (null? instructions))
  56.                (let ((first (car instructions)))
  57.              (if (and (pair? first)
  58.                   (eq? (car first) 'COMMENT))
  59.                  (loop tail (cdr instructions))
  60.                  (begin
  61.                    (set-cdr! tail
  62.                      (lap:syntax-instruction first))
  63.                    (loop (last-pair tail) (cdr instructions)))))))
  64.          (cdr holder)))))
  65.       (lambda (directives vars)
  66.     (let* ((count (relax! directives vars))
  67.            (block (assemble-objects (final-phase directives))))
  68.       (values count
  69.           block
  70.           (queue->list *entry-points*)
  71.           (symbol-table->assq-list *the-symbol-table*)))))))
  72.  
  73. (define (relax! directives vars)
  74.   (define (continue widening? count)
  75.     (clear-symbol-table!)
  76.     (initialize-symbol-table!)
  77.     (loop widening?
  78.       (phase-1 widening? directives)
  79.       (1+ count)))
  80.  
  81.   (define (loop widening? vars count)
  82.     (finish-symbol-table!)
  83.     (if (null? vars)
  84.     count
  85.     (call-with-values (lambda () (phase-2 widening? vars))
  86.       (lambda (any-modified? number-of-vars)
  87.         (cond (any-modified?
  88.            (continue false count))
  89.           ((zero? number-of-vars)
  90.            count)
  91.           (else
  92.            (continue (not widening?) count)))))))
  93.   (loop false vars 0))
  94.  
  95. ;;; Vector header and NMV header for code section
  96.  
  97. (define compiler-output-block-number-of-header-words 2)
  98.  
  99. (define starting-pc
  100.   (* compiler-output-block-number-of-header-words scheme-object-width))
  101.  
  102. ;;;; Output block generation
  103.  
  104. (define (final-phase directives)
  105.   ;; Convert label values to integers:
  106.   (for-each (lambda (pair)
  107.           (set-binding-value!
  108.            (cdr pair)
  109.            (interval-final-value (binding-value (cdr pair)))))
  110.         (symbol-table-bindings *the-symbol-table*))
  111.   (let ((code-block
  112.      (bit-string-allocate (- (->bitstring-pc
  113.                   (symbol-table-value *the-symbol-table*
  114.                               *end-label*))
  115.                  starting-pc))))
  116.     (assemble-directives! code-block
  117.               directives
  118.               (instruction-initial-position code-block))
  119.     code-block))
  120.  
  121. (define (assemble-objects code-block)
  122.   (let ((objects (map assemble-an-object (queue->list *objects*))))
  123.     (if compiler:cross-compiling?
  124.     (vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
  125.     (let* ((bl (quotient (bit-string-length code-block)
  126.                  scheme-object-width))
  127.            (non-pointer-length
  128.         ((ucode-primitive make-non-pointer-object) bl))
  129.            (objects-length (length objects))
  130.            (total-length (fix:+ 1 (fix:+ objects-length bl)))
  131.            (flo-length
  132.         (let ((flo-size (fix:quotient float-width scheme-datum-width)))
  133.           (fix:quotient (fix:+ total-length (fix:- flo-size 1))
  134.                 flo-size)))
  135.            (output-block
  136.         (object-new-type (ucode-type compiled-code-block)
  137.                  (flo:vector-cons flo-length))))
  138.       (with-absolutely-no-interrupts
  139.         (lambda ()
  140.           (let ((ob (object-new-type (ucode-type vector) output-block)))
  141.         (subvector-fill! ob
  142.                  (fix:+ bl 1)
  143.                  (system-vector-length ob)
  144.                  #f)
  145.         (vector-set! ob 0
  146.                  ((ucode-primitive primitive-object-set-type)
  147.                   (ucode-type manifest-nm-vector)
  148.                   non-pointer-length)))))
  149.       (write-bits! output-block
  150.                ;; After header just inserted.
  151.                (* scheme-object-width 2)
  152.                code-block)
  153.       ((ucode-primitive primitive-object-set! 3)
  154.        output-block 0
  155.        (object-new-type (ucode-type null) total-length))
  156.       (insert-objects! output-block objects (fix:+ bl 1))
  157.       output-block))))
  158.  
  159. (define (assemble-an-object object)
  160.   (case (car object)
  161.     ((SCHEME-OBJECT)
  162.      ;; (SCHEME-OBJECT <deflabel> <object>)
  163.      (cdr object))
  164.     ((SCHEME-EVALUATION)
  165.      ;; (SCHEME-EVALUATION <deflabel> <offlabel>)
  166.      (list (cadr object) (evaluate (caddr object) false)))
  167.     (else
  168.      (error "assemble-an-object: Unknown kind"
  169.         object))))
  170.  
  171. (define (insert-objects! v objects where)
  172.   (cond ((not (null? objects))
  173.      (system-vector-set! v where (cadar objects))
  174.      (insert-objects! v (cdr objects) (fix:+ where 1)))
  175.     ((not (fix:= where (system-vector-length v)))
  176.      (error "insert-objects!: object phase error" where))
  177.     (else unspecific)))
  178.  
  179. (define (assemble-directives! block directives initial-position)
  180.  
  181.   (define (loop directives dir-stack pc pc-stack position last-blabel blabel)
  182.  
  183.     (define (actual-bits bits l)
  184.       (instruction-insert! bits block position
  185.        (lambda (np)
  186.      (declare (integrate np))
  187.      (loop (cdr directives) dir-stack (+ pc l) pc-stack np
  188.            last-blabel blabel))))
  189.  
  190.     (define (block-offset offset last-blabel blabel)
  191.       (instruction-insert!
  192.        (block-offset->bit-string offset (eq? blabel *start-label*))
  193.        block position
  194.        (lambda (np)
  195.      (declare (integrate np))
  196.      (loop (cdr directives) dir-stack
  197.            (+ pc block-offset-width)
  198.            pc-stack np
  199.            last-blabel blabel))))
  200.  
  201.     (define (evaluation handler expression l)
  202.       (actual-bits (handler
  203.             (evaluate expression
  204.                   (if (null? pc-stack)
  205.                   (->machine-pc pc)
  206.                   (car pc-stack))))
  207.            l))
  208.  
  209.     (define (end-assembly)
  210.       (cond ((not (null? dir-stack))
  211.          (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
  212.            last-blabel blabel))
  213.         ((not (= (abs (- position initial-position))
  214.              (- pc starting-pc)))
  215.          (error "assemble-directives!: phase error"
  216.             `(PC ,starting-pc ,pc)
  217.             `(BIT-POSITION ,initial-position ,position)))
  218.         ((not (= (symbol-table-value *the-symbol-table* *end-label*)
  219.              (->machine-pc (final-pad pc))))
  220.          (error "assemble-directives!: phase error"
  221.             `(LABEL ,*end-label*)
  222.             `(ACTUAL-PC ,(->machine-pc (final-pad pc)))
  223.             `(RESOLVED-PC ,(symbol-table-value
  224.                     *the-symbol-table*
  225.                     *end-label*))))
  226.         (else
  227.          (final-pad! block pc position))))
  228.  
  229.     (if (null? directives)
  230.     (end-assembly)
  231.     (let ((this (car directives)))
  232.       (case (vector-ref this 0)
  233.         ((LABEL)
  234.          (let* ((label (vector-ref this 1))
  235.             (pcdef (symbol-table-value *the-symbol-table* label)))
  236.            (if (not (= pcdef (->machine-pc pc)))
  237.            (error "assemble-directives!: phase error"
  238.               `(LABEL ,label)
  239.               `(ACTUAL-PC ,pc)
  240.               `(RESOLVED-PC ,pcdef))))
  241.          (loop (cdr directives) dir-stack pc pc-stack position
  242.            last-blabel blabel))
  243.         ((TICK)
  244.          (loop (cdr directives) dir-stack
  245.            pc
  246.            (if (vector-ref this 1)
  247.                (cons (->machine-pc pc) pc-stack)
  248.                (cdr pc-stack))
  249.            position
  250.            last-blabel blabel))
  251.         ((FIXED-WIDTH-GROUP)
  252.          (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
  253.            pc pc-stack
  254.            position
  255.            last-blabel blabel))
  256.         ((CONSTANT)
  257.          (let ((bs (vector-ref this 1)))
  258.            (actual-bits bs (bit-string-length bs))))
  259.         ((EVALUATION)
  260.          (evaluation (vector-ref this 3)
  261.              (vector-ref this 1)
  262.              (vector-ref this 2)))
  263.         ((VARIABLE-WIDTH-EXPRESSION)
  264.          (let ((sel (car (vector-ref this 3))))
  265.            (evaluation (variable-handler-wrapper (selector/handler sel))
  266.                (vector-ref this 1)
  267.                (selector/length sel))))
  268.         ((BLOCK-OFFSET)
  269.          (let* ((label (vector-ref this 1))
  270.             (offset (evaluate `(- ,label ,blabel) '())))
  271.            (if (> offset maximum-block-offset)
  272.            (block-offset (evaluate `(- ,label ,last-blabel) '())
  273.                  label last-blabel)
  274.            (block-offset offset label blabel))))
  275.         ((PADDING)
  276.          (let ((remdr (vector-ref this 1))
  277.            (divsr (vector-ref this 2))
  278.            (padding-string (vector-ref this 3)))
  279.            (let* ((pc* (->bitstring-pc (paddify (->machine-pc pc)
  280.                             remdr divsr)))
  281.               (pc-diff (- pc* pc))
  282.               (padding-length (bit-string-length padding-string)))
  283.          (if (not (zero? (remainder pc-diff padding-length)))
  284.              (error "assemble-directives!: Bad padding"
  285.                 pc this)
  286.              (actual-bits (replicate padding-string
  287.                          (quotient pc-diff padding-length))
  288.                   pc-diff)))))
  289.         (else
  290.          (error "assemble-directives!: Unknown directive" this))))))
  291.  
  292.   (loop directives '() starting-pc '() initial-position
  293.     *start-label* *start-label*))
  294.  
  295. ;;;; Input conversion
  296.  
  297. (define (initial-phase input)
  298.   (let ((directives (make-queue)))
  299.     (define (loop to-convert pcmin pcmax pc-stack group vars)
  300.       (define (collect-group!)
  301.     (if (not (null? group))
  302.         (add-to-queue! directives
  303.                (vector 'FIXED-WIDTH-GROUP
  304.                    (car group)
  305.                    (reverse! (cdr group))))))
  306.  
  307.       (define (new-directive! dir)
  308.     (collect-group!)
  309.     (add-to-queue! directives dir))
  310.  
  311.       (define (process-label! label)
  312.     (set-label-value! (cadr label) pcmin pcmax)
  313.     (new-directive! (list->vector label)))
  314.  
  315.       (define (process-fixed-width directive width)
  316.     (loop (cdr to-convert)
  317.           (+ width pcmin) (+ width pcmax) pc-stack
  318.           (if (null? group)
  319.           (cons width (list directive))
  320.           (cons (+ width (car group))
  321.             (cons directive (cdr group))))
  322.           vars))
  323.  
  324.       (define (process-variable-width directive)
  325.     (new-directive! directive)
  326.     (call-with-values (lambda () (variable-width-lengths directive))
  327.       (lambda (minl maxl)
  328.         (loop (cdr to-convert)
  329.           (+ pcmin minl) (+ pcmax maxl)
  330.           pc-stack '()
  331.           (cons directive vars)))))
  332.  
  333.       (define (process-trivial-directive)
  334.     (loop (cdr to-convert)
  335.           pcmin pcmax pc-stack
  336.           group vars))
  337.  
  338.       (if (null? to-convert)
  339.       (let ((emin (final-pad pcmin))
  340.         (emax (+ pcmax maximum-padding-length)))
  341.         (set-label-value! *end-label* emin emax)
  342.         (collect-group!)
  343.         (values (queue->list directives) vars))
  344.  
  345.       (let ((this (car to-convert)))
  346.         (cond ((bit-string? this)
  347.            (process-fixed-width (vector 'CONSTANT this)
  348.                     (bit-string-length this)))
  349.           ((not (pair? this))
  350.            (error "initial-phase: Unknown directive" this))
  351.           (else
  352.            (case (car this)
  353.              ((CONSTANT)
  354.               (process-fixed-width (list->vector this)
  355.                        (bit-string-length (cadr this))))
  356.  
  357.              ((EVALUATION)
  358.               (process-fixed-width (list->vector this)
  359.                        (caddr this)))
  360.  
  361.              ((VARIABLE-WIDTH-EXPRESSION)
  362.               (process-variable-width
  363.                (vector 'VARIABLE-WIDTH-EXPRESSION
  364.                    (cadr this)
  365.                    (if (null? pc-stack)
  366.                    (label->machine-interval pcmin pcmax)
  367.                    (car pc-stack))
  368.                    (map list->vector (cddr this)))))
  369.              ((GROUP)
  370.               (new-directive! (vector 'TICK true))
  371.               (loop (append (cdr this)
  372.                     (cons '(TICK-OFF) (cdr to-convert)))
  373.                 pcmin pcmax
  374.                 (cons (label->machine-interval pcmin pcmax)
  375.                   pc-stack)
  376.                 '() vars))
  377.              ((TICK-OFF)
  378.               (new-directive! (vector 'TICK false))
  379.               (loop (cdr to-convert) pcmin pcmax
  380.                 (cdr pc-stack) '() vars))
  381.              ((LABEL)
  382.               (process-label! this)
  383.               (loop (cdr to-convert) pcmin pcmax pc-stack '() vars))
  384.              ((BLOCK-OFFSET)
  385.               (process-fixed-width (list->vector this)
  386.                        block-offset-width))
  387.              ((EQUATE)
  388.               (add-to-queue! *equates* (cdr this))
  389.               (process-trivial-directive))
  390.              ((SCHEME-OBJECT SCHEME-EVALUATION)
  391.               (add-to-queue! *objects* this)
  392.               (process-trivial-directive))
  393.              ((ENTRY-POINT)
  394.               (add-to-queue! *entry-points* (cadr this))
  395.               (process-trivial-directive))
  396.              ((PADDING)
  397.               (let ((directive (->padding-directive this)))
  398.             (new-directive! directive)
  399.             (after-padding
  400.              directive pcmin pcmax
  401.              (lambda (pcmin pcmax)
  402.                (loop (cdr to-convert) pcmin pcmax
  403.                  pc-stack '() vars)))))
  404.              (else
  405.               (error "initial-phase: Unknown directive" this))))))))
  406.     (loop input starting-pc starting-pc '() '() '())))
  407.  
  408. (define (phase-1 widening? directives)
  409.   (define (loop rem pcmin pcmax pc-stack vars)
  410.     (if (null? rem)
  411.     (let* ((emin (final-pad pcmin))
  412.            (emax (if (not widening?)
  413.              (+ pcmax maximum-padding-length)
  414.              emin)))
  415.       (set-label-value! *end-label* emin emax)
  416.       vars)
  417.     (let ((this (car rem)))
  418.       (case (vector-ref this 0)
  419.         ((LABEL)
  420.          (set-label-value! (vector-ref this 1) pcmin pcmax)
  421.          (loop (cdr rem) pcmin pcmax pc-stack vars))
  422.         ((FIXED-WIDTH-GROUP)
  423.          (let ((l (vector-ref this 1)))
  424.            (loop (cdr rem)
  425.              (+ pcmin l)
  426.              (+ pcmax l)
  427.              pc-stack
  428.              vars)))
  429.         ((VARIABLE-WIDTH-EXPRESSION)
  430.          (vector-set! this 2
  431.               (if (null? pc-stack)
  432.                   (label->machine-interval pcmin pcmax)
  433.                   (car pc-stack)))
  434.          (call-with-values (lambda () (variable-width-lengths this))
  435.            (lambda (minl maxl)
  436.          (loop (cdr rem)
  437.                (+ pcmin minl)
  438.                (+ pcmax (if widening? minl maxl))
  439.                pc-stack
  440.                (cons this vars)))))
  441.         ((TICK)
  442.          (loop (cdr rem)
  443.            pcmin pcmax
  444.            (if (vector-ref this 1)
  445.                (cons (label->machine-interval pcmin pcmax) pc-stack)
  446.                (cdr pc-stack))
  447.            vars))
  448.         ((PADDING)
  449.          (after-padding
  450.           this pcmin pcmax
  451.           (lambda (pcmin pcmax)
  452.         (loop (cdr rem) pcmin pcmax pc-stack vars))))
  453.         (else
  454.          (error "phase-1: Unknown directive" this))))))
  455.   (loop directives starting-pc starting-pc '() '()))
  456.  
  457. (define (phase-2 widening? vars)
  458.   (let loop ((vars vars) (modified? #f) (count 0))
  459.     (if (null? vars)
  460.     (values modified? count)
  461.     (call-with-values
  462.         (lambda ()
  463.           (let ((var (car vars)))
  464.         (call-with-values
  465.             (lambda ()
  466.               (interval-values (evaluate (vector-ref var 1)
  467.                          (vector-ref var 2))))
  468.           (lambda (low high)
  469.             (process-variable var widening? low high)))))
  470.       (lambda (determined? filtered?)
  471.         (loop (cdr vars)
  472.           (or modified? filtered?)
  473.           (if determined? count (+ count 1))))))))
  474.  
  475. (define (process-variable var widening? minval maxval)
  476.   (let loop ((dropped-some? #f))
  477.     (let ((sels (vector-ref var 3)))
  478.       (if (null? sels)
  479.       (error "Variable-width field cannot be resolved:" var))
  480.       (let ((low (selector/low (car sels)))
  481.         (high (selector/high (car sels))))
  482.     (cond ((and (or (null? low) (<= low minval))
  483.             (or (null? high) (<= maxval high)))
  484.            (if (not widening?)
  485.            (variable-width->fixed! var (car sels)))
  486.            (values #t dropped-some?))
  487.           ((and (or (null? low) (<= low maxval))
  488.             (or (null? high) (<= minval high)))
  489.            (values #f dropped-some?))
  490.           (else
  491.            (vector-set! var 3 (cdr sels))
  492.            (loop #t)))))))
  493.  
  494. (define (variable-width->fixed! var sel)
  495.   (let* ((l (selector/length sel))
  496.      (v (vector 'EVALUATION
  497.             (vector-ref var 1)    ; Expression
  498.             (selector/length sel)
  499.             (variable-handler-wrapper (selector/handler sel)))))
  500.     (vector-set! var 0 'FIXED-WIDTH-GROUP)
  501.     (vector-set! var 1 l)
  502.     (vector-set! var 2 (list v))
  503.     (vector-set! var 3 '())))
  504.  
  505. (define (variable-handler-wrapper handler)
  506.   (lambda (value)
  507.     (let ((l (handler value)))
  508.       (if (null? l)
  509.       (bit-string-allocate 0)
  510.       (list->bit-string l)))))
  511.  
  512. (define (list->bit-string l)
  513.   (if (null? (cdr l))
  514.       (car l)
  515.       (instruction-append (car l)
  516.               (list->bit-string (cdr l)))))
  517.  
  518. (define (replicate bstring n-times)
  519.   (let* ((blength (bit-string-length bstring))
  520.      (result (make-bit-string (* n-times blength) false)))
  521.     (do ((offset 0 (+ offset blength))
  522.      (ctr 0 (1+ ctr)))
  523.     ((>= ctr n-times))
  524.       (bit-substring-move-right! bstring 0 blength result offset))
  525.     result))
  526.  
  527. (define (final-pad! block pc position)
  528.   (instruction-insert!
  529.    (replicate padding-string
  530.           (quotient (- (final-pad pc) pc)
  531.             (bit-string-length padding-string)))
  532.    block
  533.    position
  534.    (lambda (new-position)
  535.      new-position            ; ignored
  536.      unspecific)))
  537.  
  538. (define (->padding-directive this)
  539.   (let ((remdr (cadr this))
  540.     (divsr (caddr this))
  541.     (bstring (if (null? (cdddr this))
  542.              padding-string
  543.              (cadddr this))))
  544.     (vector 'PADDING (modulo remdr divsr) divsr bstring)))
  545.  
  546. (define-integrable (after-padding directive pcmin pcmax recvr)
  547.   (let ((remdr (vector-ref directive 1))
  548.     (divsr (vector-ref directive 2)))
  549.     (recvr (->bitstring-pc (paddify (->machine-pc pcmin) remdr divsr))
  550.        (->bitstring-pc (paddify (->machine-pc pcmax) remdr divsr)))))