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