#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bittop.scm,v 1.15 1992/06/12 01:43:44 jinx Exp $
+$Id: bittop.scm,v 1.16 1993/12/08 17:42:47 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; package: (compiler assembler)
(declare (usual-integrations))
-
+\f
(define *equates*)
(define *objects*)
(define *entry-points*)
-(define *linkage-info*)
(define *the-symbol-table*)
(define *start-label*)
(define *end-label*)
-;;; Vector header and NMV header for code section
-
-(define compiler-output-block-number-of-header-words 2)
-
-(define starting-pc
- (* compiler-output-block-number-of-header-words scheme-object-width))
-\f
;;;; Assembler top level procedure
(define (assemble start-label instructions)
(fluid-let ((*equates* (make-queue))
(*objects* (make-queue))
(*entry-points* (make-queue))
- (*linkage-info* (make-queue))
(*the-symbol-table* (make-symbol-table))
(*start-label* start-label)
(*end-label* (generate-uninterned-symbol 'END-LABEL-)))
(values count
block
(queue->list *entry-points*)
- (symbol-table->assq-list *the-symbol-table*)
- (queue->list *linkage-info*)))))))
+ (symbol-table->assq-list *the-symbol-table*)))))))
(define (relax! directives vars)
(define (loop vars count)
count)))))
(loop vars 0))
\f
+;;; Vector header and NMV header for code section
+
+(define compiler-output-block-number-of-header-words 2)
+
+(define starting-pc
+ (* compiler-output-block-number-of-header-words scheme-object-width))
+
;;;; Output block generation
(define (final-phase directives)
(instruction-initial-position code-block))
code-block))
+#|
+
(define (assemble-objects code-block)
- (let ((objects (queue->list *objects*)))
+ (let ((objects (map assemble-an-object (queue->list *objects*))))
(if compiler:cross-compiling?
(vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
(let* ((bl (quotient (bit-string-length code-block)
(object-new-type (ucode-type compiled-code-block)
output-block)))))
+|#
+\f
+(define (assemble-objects code-block)
+ (let ((objects (map assemble-an-object (queue->list *objects*))))
+ (if compiler:cross-compiling?
+ (vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (objects-length (length objects))
+ (total-length (fix:+ 1 (fix:+ objects-length bl)))
+ (flo-length
+ (let ((flo-size (fix:quotient float-width scheme-datum-width)))
+ (fix:quotient (fix:+ total-length (fix:- flo-size 1))
+ flo-size)))
+ (output-block
+ (object-new-type (ucode-type compiled-code-block)
+ (flo:vector-cons flo-length))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((ob (object-new-type (ucode-type vector) output-block)))
+ (subvector-fill! ob
+ (fix:+ bl 1)
+ (vector-length ob)
+ #f)
+ (vector-set! ob 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length)))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ ((ucode-primitive primitive-object-set! 3)
+ output-block 0
+ (object-new-type (ucode-type null) total-length))
+ (insert-objects! output-block objects (fix:+ bl 1))
+ output-block))))
+
+(define (assemble-an-object object)
+ (case (car object)
+ ((SCHEME-OBJECT)
+ ;; (SCHEME-OBJECT <deflabel> <object>)
+ (cdr object))
+ ((SCHEME-EVALUATION)
+ ;; (SCHEME-EVALUATION <deflabel> <offlabel>)
+ (list (cadr object) (evaluate (caddr object) false)))
+ (else
+ (error "assemble-an-object: Unknown kind"
+ object))))
+
(define (insert-objects! v objects where)
(cond ((not (null? objects))
- (vector-set! v where (cadar objects))
- (insert-objects! v (cdr objects) (1+ where)))
- ((not (= where (vector-length v)))
+ (system-vector-set! v where (cadar objects))
+ (insert-objects! v (cdr objects) (fix:+ where 1)))
+ ((not (fix:= where (system-vector-length v)))
(error "insert-objects!: object phase error" where))
(else unspecific)))
-
-(define (pad! block pc position)
- (let ((l (bit-string-length padding-string)))
- (let loop ((to-pad (- (pad pc) pc))
- (position position))
- (if (not (zero? to-pad))
- (if (< to-pad l)
- (error "pad!: Bad padding length" to-pad)
- (instruction-insert! padding-string block position
- (lambda (new-position)
- (declare (integrate new-position))
- (loop (- to-pad l) new-position))))))))
\f
(define (assemble-directives! block directives initial-position)
(error "assemble-directives!: phase error"
`(PC ,starting-pc ,pc)
`(BIT-POSITION ,initial-position ,position)))
+ ((not (= (symbol-table-value *the-symbol-table* *end-label*)
+ (->machine-pc (final-pad pc))))
+ (error "assemble-directives!: phase error"
+ `(LABEL ,*end-label*)
+ `(ACTUAL-PC ,(->machine-pc (final-pad pc)))
+ `(RESOLVED-PC ,(symbol-table-value
+ *the-symbol-table*
+ *end-label*))))
(else
- (pad! block pc position))))
+ (final-pad! block pc position))))
\f
(if (null? directives)
(end-assembly)
(let ((this (car directives)))
(case (vector-ref this 0)
((LABEL)
+ (let* ((label (vector-ref this 1))
+ (pcdef (symbol-table-value *the-symbol-table* label)))
+ (if (not (= pcdef (->machine-pc pc)))
+ (error "assemble-directives!: phase error"
+ `(LABEL ,label)
+ `(ACTUAL-PC ,pc)
+ `(RESOLVED-PC ,pcdef))))
(loop (cdr directives) dir-stack pc pc-stack position
last-blabel blabel))
((TICK)
(block-offset (evaluate `(- ,label ,last-blabel) '())
label last-blabel)
(block-offset offset label blabel))))
+ ((PADDING)
+ (let ((remdr (vector-ref this 1))
+ (divsr (vector-ref this 2))
+ (padding-string (vector-ref this 3)))
+ (let* ((pc* (->bitstring-pc (paddify (->machine-pc pc)
+ remdr divsr)))
+ (pc-diff (- pc* pc))
+ (padding-length (bit-string-length padding-string)))
+ (if (not (zero? (remainder pc-diff padding-length)))
+ (error "assemble-directives!: Bad padding"
+ pc this)
+ (actual-bits (replicate padding-string
+ (quotient pc-diff padding-length))
+ pc-diff)))))
(else
(error "assemble-directives!: Unknown directive" this))))))
(loop (cdr to-convert)
pcmin pcmax pc-stack
group vars))
-\f
+
(if (null? to-convert)
- (let ((emin (pad pcmin))
+ (let ((emin (final-pad pcmin))
(emax (+ pcmax maximum-padding-length)))
(symbol-table-define! *the-symbol-table*
*end-label*
(make-machine-interval emin emax))
(collect-group!)
(values (queue->list directives) vars))
+\f
(let ((this (car to-convert)))
(cond ((bit-string? this)
(process-fixed-width (vector 'CONSTANT this)
((EQUATE)
(add-to-queue! *equates* (cdr this))
(process-trivial-directive))
- ((SCHEME-OBJECT)
- (add-to-queue! *objects* (cdr this))
+ ((SCHEME-OBJECT SCHEME-EVALUATION)
+ (add-to-queue! *objects* this)
(process-trivial-directive))
((ENTRY-POINT)
(add-to-queue! *entry-points* (cadr this))
(process-trivial-directive))
- ((LINKAGE-INFORMATION)
- (add-to-queue! *linkage-info* (cdr this))
- (process-trivial-directive))
+ ((PADDING)
+ (let ((directive (->padding-directive this)))
+ (new-directive! directive)
+ (after-padding
+ directive pcmin pcmax
+ (lambda (pcmin pcmax)
+ (loop (cdr to-convert) pcmin pcmax
+ pc-stack '() vars)))))
(else
(error "initial-phase: Unknown directive" this))))))))
(loop input starting-pc starting-pc '() '() '())))
(define (phase-1 directives)
(define (loop rem pcmin pcmax pc-stack vars)
(if (null? rem)
- (let ((emin (pad pcmin))
+ (let ((emin (final-pad pcmin))
(emax (+ pcmax maximum-padding-length)))
(symbol-table-define! *the-symbol-table*
*end-label*
(cons (make-machine-interval pcmin pcmax) pc-stack)
(cdr pc-stack))
vars))
+ ((PADDING)
+ (after-padding
+ this pcmin pcmax
+ (lambda (pcmin pcmax)
+ (loop (cdr rem) pcmin pcmax pc-stack vars))))
(else
(error "phase-1: Unknown directive" this))))))
(loop directives starting-pc starting-pc '() '()))
(if (null? (cdr l))
(car l)
(instruction-append (car l)
- (list->bit-string (cdr l)))))
\ No newline at end of file
+ (list->bit-string (cdr l)))))
+
+(define (replicate bstring n-times)
+ (let* ((blength (bit-string-length bstring))
+ (result (make-bit-string (* n-times blength) false)))
+ (do ((offset 0 (+ offset blength))
+ (ctr 0 (1+ ctr)))
+ ((>= ctr n-times))
+ (bit-substring-move-right! bstring 0 blength result offset))
+ result))
+
+(define (final-pad! block pc position)
+ (instruction-insert!
+ (replicate padding-string
+ (quotient (- (final-pad pc) pc)
+ (bit-string-length padding-string)))
+ block
+ position
+ (lambda (new-position)
+ new-position ; ignored
+ unspecific)))
+
+(define (->padding-directive this)
+ (let ((remdr (cadr this))
+ (divsr (caddr this))
+ (bstring (if (null? (cdddr this))
+ padding-string
+ (cadddr this))))
+ (vector 'PADDING (modulo remdr divsr) divsr bstring)))
+
+(define-integrable (after-padding directive pcmin pcmax recvr)
+ (let ((remdr (vector-ref directive 1))
+ (divsr (vector-ref directive 2)))
+ (recvr (->bitstring-pc (paddify (->machine-pc pcmin) remdr divsr))
+ (->bitstring-pc (paddify (->machine-pc pcmax) remdr divsr)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/bitutl.scm,v 1.6 1992/07/05 13:32:27 jinx Exp $
+$Id: bitutl.scm,v 1.7 1993/12/08 17:43:16 gjr Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; Extra symbol table operations
(define (clear-symbol-table!)
- (set! *the-symbol-table* (make-symbol-table)))
+ (set! *the-symbol-table* (make-symbol-table))
+ unspecific)
(define (initialize-symbol-table!)
(symbol-table-define! *the-symbol-table* *start-label* 0))
(define (finish-symbol-table!)
- (define (process-objects obj pcmin pcmax)
- (if (null? obj)
+ (define (process-objects objs pcmin pcmax)
+ (if (null? objs)
'DONE
- (begin
+ (let ((object (car objs)))
(symbol-table-define! *the-symbol-table*
- (caar obj)
+ (cadr object) ; label
(make-machine-interval pcmin pcmax))
- (process-objects (cdr obj)
+ (process-objects (cdr objs)
(+ pcmin scheme-object-width)
(+ pcmax scheme-object-width)))))
;; Handle equates
(for-each (lambda (equate)
- (symbol-table-define!
- *the-symbol-table*
- (car equate)
- (evaluate (cadr equate) false)))
+ (symbol-table-define! *the-symbol-table*
+ (car equate)
+ (evaluate (cadr equate) false)))
(queue->list *equates*)))
\f
;;;; Expression evaluation and intervals
((number? exp) exp)
((not (symbol? exp))
(error "evaluate: bad expression" exp))
- ((eq? exp '*PC*) pc-value)
+ ((eq? exp '*PC*)
+ (if (not pc-value)
+ (error "evaluate: *PC* found with no PC defined"))
+ pc-value)
(else
(symbol-table-value *the-symbol-table* exp))))
(inner expression))
-(declare (integrate-operator ->machine-pc make-machine-interval
- make-interval interval?
- interval-low interval-high))
-
-(define (->machine-pc pc)
- (declare (integrate pc))
+(define-integrable (->machine-pc pc)
(paranoid-quotient pc addressing-granularity))
+(define-integrable (->bitstring-pc pc)
+ (* pc addressing-granularity))
+
+(define (paddify pc-val remdr divsr)
+ (let ((aremdr (remainder pc-val divsr)))
+ (+ pc-val
+ (if (<= aremdr remdr)
+ (- remdr aremdr)
+ (+ remdr (- divsr aremdr))))))
+
;; Machine intervals are always in addressing units.
-(define (make-machine-interval low high)
- (declare (integrate low high))
+(define-integrable (make-machine-interval low high)
(make-interval (->machine-pc low)
(->machine-pc high)))
value
(make-interval value value)))
-(define (make-interval low high)
- (declare (integrate low high))
+(define-integrable (make-interval low high)
(vector 'INTERVAL low high))
-(define (interval? obj)
- (declare (integrate obj))
+(define-integrable (interval? obj)
(and (vector? obj)
(eq? (vector-ref obj 0) 'INTERVAL)))
-(define (interval-low obj)
- (declare (integrate obj))
+(define-integrable (interval-low obj)
(vector-ref obj 1))
-(define (interval-high obj)
- (declare (integrate obj))
+(define-integrable (interval-high obj)
(vector-ref obj 2))
(define (paranoid-quotient dividend divisor)
(integer-divide-quotient result)
(error "paranoid-quotient: not a multiple" dividend divisor))))
-(define (pad pcvalue)
- (let ((r (remainder pcvalue scheme-object-width)))
- (if (zero? r)
- pcvalue
- (+ pcvalue (- scheme-object-width r)))))
+(define (final-pad pcvalue)
+ (paddify pcvalue 0 scheme-object-width))
\f
;;;; Operators
;; Either argument can be an interval
-(define ((symmetric scalar) op1 op2)
- (if (interval? op1)
- (if (interval? op2)
- (make-interval (scalar (interval-low op1) (interval-low op2))
- (scalar (interval-high op1) (interval-high op2)))
- (make-interval (scalar (interval-low op1) op2)
- (scalar (interval-high op1) op2)))
- (if (interval? op2)
- (make-interval (scalar op1 (interval-low op2))
- (scalar op1 (interval-high op2)))
- (scalar op1 op2))))
+(define-operator! '+
+ (lambda (op1 op2)
+ (cond ((not (interval? op2))
+ (if (not (interval? op1))
+ (+ op1 op2)
+ (make-interval (+ (interval-low op1) op2)
+ (+ (interval-high op1) op2))))
+ ((not (interval? op1))
+ (make-interval (+ op1 (interval-low op2))
+ (+ op1 (interval-high op2))))
+ (else
+ (make-interval (+ (interval-low op1) (interval-low op2))
+ (+ (interval-high op1) (interval-high op2)))))))
-;; Only the first argument can be an interval
+(define-operator! '-
+ (lambda (op1 op2)
+ (cond ((not (interval? op2))
+ (if (not (interval? op1))
+ (- op1 op2)
+ (make-interval (- (interval-low op1) op2)
+ (- (interval-high op1) op2))))
+ ((not (interval? op1))
+ (make-interval (- op1 (interval-high op2))
+ (- op1 (interval-low op2))))
+ (else
+ (make-interval (- (interval-low op1) (interval-high op2))
+ (- (interval-high op1) (interval-low op2)))))))
+\f
+;; Only one argument can be an interval, both assumed non-negative.
-(define ((asymmetric op) op1 op2)
- (if (interval? op1)
- (make-interval (op (interval-low op1) op2)
- (op (interval-high op1) op2))
- (op op1 op2)))
+(define-operator! '*
+ (lambda (op1 op2)
+ (cond ((not (interval? op2))
+ (if (not (interval? op1))
+ (* op1 op2)
+ (make-interval (* (interval-low op1) op2)
+ (* (interval-high op1) op2))))
+ ((not (interval? op1))
+ (make-interval (* op1 (interval-low op2))
+ (* op1 (interval-high op2))))
+ (else
+ (error "evaluate: Both arguments are intervals" '* op1 op2)))))
-(define-operator! '+ (symmetric +))
-(define-operator! '- (symmetric -))
+;; Only the first argument can be an interval
-(define-operator! '/ (asymmetric paranoid-quotient))
-(define-operator! 'remainder (asymmetric remainder))
+(define ((asymmetric name op) op1 op2)
+ (cond ((interval? op2)
+ (error "evaluate: Second operand is an interval" name op1 op2))
+ ((not (interval? op1))
+ (op op1 op2))
+ (else
+ (make-interval (op (interval-low op1) op2)
+ (op (interval-high op1) op2)))))
-;; Only one argument can be an interval.
+(define-operator! '/ (asymmetric '/ paranoid-quotient))
+(define-operator! 'QUOTIENT (asymmetric 'QUOTIENT quotient))
-(define-operator! '*
+(define-operator! 'REMAINDER
(lambda (op1 op2)
- (cond ((interval? op1)
- (make-interval (* (interval-low op1) op2)
- (* (interval-high op1) op2)))
- ((interval? op2)
- (make-interval (* op1 (interval-low op2))
- (* op1 (interval-high op2))))
- (else (* op1 op2)))))
+ (cond ((interval? op2)
+ (error "evaluate: Second operand is an interval"
+ 'REMAINDER op1 op2))
+ ((not (interval? op1))
+ (remainder op1 op2))
+ (else
+ (let ((rlow (remainder (interval-low op1) op2))
+ (rhigh (remainder (interval-high op1) op2)))
+ (if (> rlow rhigh)
+ (make-interval rhigh rlow)
+ (make-interval rlow rhigh)))))))
\f
;;;; Variable width expression utilities
#| -*-Scheme-*-
-$Id: lapgn1.scm,v 4.15 1993/08/26 05:47:34 gjr Exp $
+$Id: lapgn1.scm,v 4.16 1993/12/08 17:43:55 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
(begin
(create-edge! current-bblock set-snode-next-edge! bblock)
(set-bblock-continuations! current-bblock (list bblock))
- (set-sblock-continuation! current-bblock bblock)))))
\ No newline at end of file
+ (set-sblock-continuation! current-bblock bblock)))))
+
+(define (lap:comment comment)
+ (if compiler:generate-lap-files?
+ (LAP (COMMENT (LAP ,comment)))
+ (LAP)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syerly.scm,v 1.8 1991/10/30 20:48:53 cph Exp $
+$Id: syerly.scm,v 1.9 1993/12/08 17:44:21 gjr Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; Syntax time instruction expansion
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(cond ((eq? (car instruction) 'UNQUOTE)
(if-not-expanded))
((memq (car instruction)
- '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET))
+ '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
+ ENTRY-POINT LABEL BLOCK-OFFSET))
(if-expanded
(scode/make-combination
(scode/make-variable 'DIRECTIVE->INSTRUCTION-SEQUENCE)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.25 1990/01/18 22:42:14 cph Rel $
+$Id: syntax.scm,v 1.26 1993/12/08 17:44:53 gjr Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; LAP Syntaxer
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define (lap:syntax-instruction instruction)
(if (memq (car instruction)
- '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL BLOCK-OFFSET))
+ '(EQUATE SCHEME-OBJECT SCHEME-EVALUATION
+ ENTRY-POINT LABEL BLOCK-OFFSET
+ PADDING))
(list instruction)
(let ((match-result (instruction-lookup instruction)))
(if (not match-result)
#| -*-Scheme-*-
-$Id: asstop.scm,v 1.9 1993/11/29 18:38:12 gjr Exp $
+$Id: asstop.scm,v 1.10 1993/12/08 17:45:42 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(*external-labels*)
(*end-of-block-code*)
(*next-constant*)
- (*interned-constants*)
- (*interned-variables*)
(*interned-assignments*)
- (*interned-uuo-links*)
+ (*interned-constants*)
(*interned-global-links*)
(*interned-static-variables*)
+ (*interned-uuo-links*)
+ (*interned-variables*)
(*label-bindings*)
(*code-vector*)
(*entry-points*)
(set! *external-labels*)
(set! *end-of-block-code*)
(set! *next-constant*)
- (set! *interned-constants*)
- (set! *interned-variables*)
(set! *interned-assignments*)
- (set! *interned-uuo-links*)
+ (set! *interned-constants*)
(set! *interned-global-links*)
(set! *interned-static-variables*)
+ (set! *interned-uuo-links*)
+ (set! *interned-variables*)
(set! *label-bindings*)
(set! *code-vector*)
(set! *entry-points*)
(set! *block-associations* '())
(set! *block-label* (generate-label))
(set! *external-labels* '())
- (set! *end-of-block-code* (LAP))
+ (set! *end-of-block-code* '())
(set! *next-constant* 0)
- (set! *interned-constants* '())
- (set! *interned-variables* '())
(set! *interned-assignments* '())
- (set! *interned-uuo-links* '())
+ (set! *interned-constants* '())
(set! *interned-global-links* '())
(set! *interned-static-variables* '())
+ (set! *interned-uuo-links* '())
+ (set! *interned-variables* '())
unspecific)
\f
;;;; Assembler and linker
"Assembly"
(lambda ()
(with-values (lambda () (assemble *block-label* (last-reference *lap*)))
- (lambda (count code-vector labels bindings linkage-info)
- linkage-info ;ignored
+ (lambda (count code-vector labels bindings)
(set! *code-vector* code-vector)
(set! *entry-points* labels)
(set! *label-bindings* bindings)
(set! *entry-label* label)
(set! *current-label-number* 0)
(set! *next-constant* 0)
- (set! *interned-constants* '())
- (set! *interned-variables* '())
(set! *interned-assignments* '())
- (set! *interned-uuo-links* '())
+ (set! *interned-constants* '())
(set! *interned-global-links* '())
(set! *interned-static-variables* '())
+ (set! *interned-uuo-links* '())
+ (set! *interned-variables* '())
(set! *block-label* (generate-label))
(set! *external-labels* '())
(set! *ic-procedure-headers* '())
#| -*-Scheme-*-
-$Id: make.scm,v 4.102 1993/11/18 01:21:12 cph Exp $
+$Id: make.scm,v 4.103 1993/12/08 17:50:41 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(initialize-package! '(COMPILER DECLARATIONS)))
(add-system!
(make-system (string-append "Liar (" architecture-name ")")
- 4 101
+ 4 102
'())))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: compiler.pkg,v 1.45 1993/10/12 07:30:11 cph Exp $
+$Id: compiler.pkg,v 1.46 1993/12/08 17:47:44 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(parent (compiler lap-syntaxer))
(export (compiler lap-syntaxer)
add-end-of-block-code!
+ add-extra-code!
bblock-linearize-lap
+ extra-code-block/xtra
+ declare-extra-code-block!
+ find-extra-code-block
linearize-lap
- set-current-branches!)
+ set-current-branches!
+ set-extra-code-block/xtra!)
(export (compiler top-level)
*end-of-block-code*
linearize-lap))
#| -*-Scheme-*-
-$Id: instr2.scm,v 1.5 1993/02/14 00:53:30 gjr Exp $
+$Id: instr2.scm,v 1.6 1993/12/08 17:48:22 gjr Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
(1 (vector-ref compl 2))
(5 reg))))))
- (indexed-cache
- (macro (keyword opcode extn bit)
+ (indexed-d-cache
+ (macro (keyword extn)
`(define-instruction ,keyword
- (((? compl complx) (INDEX (? index-reg) (? space) (? base)))
- (LONG (6 ,opcode)
+ (((? compl m-val) (INDEX (? index-reg) (? space) (? base)))
+ (LONG (6 #x01)
(5 base)
(5 index-reg)
(2 space)
- (1 (vector-ref compl 0))
- (1 ,bit)
- (2 (vector-ref compl 1))
- (4 ,extn)
- (1 (vector-ref compl 2))
- (5 #b00000)))))))
+ (8 ,extn)
+ (1 compl)
+ (5 #x0))))))
+
+ (indexed-i-cache
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl m-val)
+ (INDEX (? index-reg) (? space sr3) (? base)))
+ (LONG (6 #x01)
+ (5 base)
+ (5 index-reg)
+ (3 space)
+ (7 ,extn)
+ (1 compl)
+ (5 #x0)))))))
(indexed-load LDWX #x03 #x2)
(indexed-load LDHX #x03 #x1)
(indexed-store FSTWX #x09 #x8)
(indexed-store FSTDX #x0b #x8)
- (indexed-cache PDC #x01 #xd 1)
- (indexed-cache FDC #x01 #xa 1)
- (indexed-cache FIC #x01 #xa 0)
- (indexed-cache FDCE #x01 #xb 1)
- (indexed-cache FICE #x01 #xb 0))
+ (indexed-d-cache PDC #x4e)
+ (indexed-d-cache FDC #x4a)
+ (indexed-i-cache FIC #x0a)
+ (indexed-d-cache FDCE #x4b)
+ (indexed-i-cache FICE #x0b))
\f
(let-syntax ((scalr-short-load
(macro (keyword extn)
\f
;;;; Assembler pseudo-ops
+(define-instruction USHORT
+ ((() (? high) (? low))
+ (LONG (16 high UNSIGNED)
+ (16 low UNSIGNED))))
+
(define-instruction WORD
((() (? expression))
(LONG (32 expression SIGNED))))
#| -*-Scheme-*-
-$Id: lapgen.scm,v 4.45 1993/10/28 04:59:46 gjr Exp $
+$Id: lapgen.scm,v 4.46 1993/12/08 17:48:53 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
flonum-truncate
flonum-ceiling
flonum-floor
- flonum-atan2))
-
+ flonum-atan2
+ compiled-code-bkpt
+ compiled-closure-bkpt
+ copy-closure-pattern
+ copy-multiclosure-pattern))
+\f
;; There is a NOP here because otherwise the return address would have
;; to be adjusted by the hook code. This gives more flexibility to the
;; compiler since it may be able to eliminate the NOP by moving an
#| -*-Scheme-*-
-$Id: lapopt.scm,v 1.13 1993/07/01 03:14:14 gjr Exp $
+$Id: lapopt.scm,v 1.14 1993/12/08 17:49:18 gjr Exp $
Copyright (c) 1991-1993 Massachusetts Institute of Technology
;;;; An instruction classifier and decomposer
(define-integrable (float-reg reg)
- reg ; ignore
(+ 32 reg))
(define (classify-instruction instr)
- ;; returns: type target source-1 source-2 offset
+ ;; (values type target source-1 source-2 offset)
;; This needs the following:
;; - Loads with base modification (LDWM)
;; - Third source (indexed loads)
- ;; - Floats
(let ((opcode (car instr)))
(cond ((memq opcode '(ANDCM AND OR XOR UXOR SUB DS SUBT
SUBB ADD SH1ADD SH2ADD SH3ADD ADDC
(list-ref instr 2)
(cadddr offset)
(cadr offset))))
- ((memq opcode '(STWM))
+ ((memq opcode '(STWM STWS))
;; source1 (offset n m target/source)
(let* ((offset (list-ref instr 3))
(base (cadddr offset)))
((memq opcode '(PCR-HOOK))
<>)
((memq opcode '(LABEL EQUATE ENTRY-POINT
- EXTERNAL-LABEL BLOCK-OFFSET))
+ EXTERNAL-LABEL BLOCK-OFFSET
+ SCHEME-OBJECT SCHEME-EVALUATION PADDING))
(values 'DIRECTIVE false false false false))
|#
(else
(define (offset-fits? offset opcode)
(and (number? offset)
- (memq opcode '(ldw ldb ldo ldh stw stb sth stwm ldwm))
+ (memq opcode '(LDW LDB LDO LDH STW STB STH STWM LDWM
+ STWS LDWS FLDWS FLDDS FSTWS FSTDS))
(<= -8192 offset 8191)))
\f
;;;; Utilities
;; (COMBT (<) ...)
(and (pair? (cadr instr))
(not (memq (car instr)
- '(B BL BV BLR BLE BE)))
+ '(B BL BV BLR BLE BE
+ LDWS LDHS LDBS LDCWS
+ STWS STHS STBS STBYS
+ FLDWS FLDDS FSTWS FSTDS)))
;; or SGL, or QUAD, but not used now.
(not (memq 'DBL (cadr instr)))))
(define (find-or-label instrs)
(and (not (null? instrs))
- (if (memq (caar instrs) '(COMMENT SCHEME-OBJECT EQUATE))
+ (if (memq (caar instrs)
+ '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
(find-or-label (cdr instrs))
instrs)))
(define (find-non-label instrs)
(and (not (null? instrs))
- (if (memq (caar instrs) '(LABEL COMMENT SCHEME-OBJECT EQUATE))
+ (if (memq (caar instrs)
+ '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
(find-non-label (cdr instrs))
instrs)))
#| -*-Scheme-*-
-$Id: rules3.scm,v 4.40 1993/07/01 03:23:35 gjr Exp $
+$Id: rules3.scm,v 4.41 1993/12/08 17:49:54 gjr Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(define internal-continuation-code-word
(make-code-word #xff #xfc))
+;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface
+
+(define internal-closure-code-word
+ (make-code-word #xff #xfa))
+
(define (continuation-code-word label)
(frame-size->code-word
(if label
(if (zero? nentries)
(error "Closure header for closure with no entries!"
internal-label))
- (let ((rtl-proc (label->object internal-label)))
- (let ((gc-label (generate-label))
- (external-label (rtl-procedure/external-label rtl-proc)))
- (LAP (LABEL ,gc-label)
- ,@(invoke-interface code:compiler-interrupt-closure)
- ,@(make-external-label
- (internal-procedure-code-word rtl-proc)
- external-label)
- ;; This code must match the code and count in microcode/cmpint2.h
- (DEP () 0 31 2 ,regnum:ble-return)
- ,@(address->entry regnum:ble-return)
- (STWM () ,regnum:ble-return (OFFSET -4 0 ,regnum:stack-pointer))
- (LABEL ,internal-label)
- ,@(interrupt-check internal-label gc-label)))))
+
+ ;; Closures used to use (internal-procedure-code-word rtl-proc)
+ ;; instead of internal-closure-code-word.
+ ;; This confused the bkpt utilties and was unnecessary because
+ ;; these entry points cannot properly be used as return addresses.
+
+ (let* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc)))
+ (let ((suffix
+ (lambda (gc-label)
+ (LAP ,@(make-external-label internal-closure-code-word
+ external-label)
+ ,@(address->entry g25)
+ (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer))
+ (LABEL ,internal-label)
+ ,@(interrupt-check internal-label gc-label)))))
+ (share-instruction-sequence!
+ 'CLOSURE-GC-STUB
+ suffix
+ (lambda (gc-label)
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-interface code:compiler-interrupt-closure)
+ ,@(suffix gc-label)))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
(else
(cons-multiclosure target nentries size (vector->list entries)))))
\f
+#|
+;;; Old style closure consing -- Out of line.
+
(define (%cons-closure target total-size size core)
(let* ((flush-reg (require-registers! regnum:first-arg
#| regnum:addil-result |#
,@(load-offset 4 regnum:free-pointer target)
,@(generate-entries 12 entries)))))
\f
-;; Magic for compiled entries.
-
-(define compiled-entry-type-im5
- (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
- (immed (integer-divide-quotient qr)))
- (if (or (not (= scheme-type-width 6))
- (not (zero? (integer-divide-remainder qr)))
- (not (<= 0 immed #x1F)))
- (error "HPPA RTL rules3: closure header rule assumptions violated!"))
- (if (<= immed #x0F)
- immed
- (- immed #x20))))
-
-(define-integrable (address->entry register)
- (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
+;; Utilities for old-style closure consing.
(define (load-entry-format code-word gc-offset dest)
(load-immediate (+ (* code-word #x10000)
4
,regnum:scheme-to-interface-ble)
(@PCR ,entry-label)))))
+|#
+
+;; Magic for compiled entries.
+
+(define compiled-entry-type-im5
+ (let* ((qr (integer-divide (ucode-type compiled-entry) 2))
+ (immed (integer-divide-quotient qr)))
+ (if (or (not (= scheme-type-width 6))
+ (not (zero? (integer-divide-remainder qr)))
+ (not (<= 0 immed #x1F)))
+ (error "HPPA RTL rules3: closure header rule assumptions violated!"))
+ (if (<= immed #x0F)
+ immed
+ (- immed #x20))))
+
+(define-integrable (address->entry register)
+ (LAP (DEPI () ,compiled-entry-type-im5 4 5 ,register)))
+\f
+;;; New style closure consing using compiler-prepared and
+;;; linker-maintained patterns
+
+;; Compiled code blocks are aligned like floating-point numbers and vectors.
+;; That is, the address of their header word is congruent 4 mod 8
+
+(define *initial-dword-offset* 4)
+(define *closure-padding-bitstring* (make-bit-string 32 false))
+
+;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h
+
+(define *ldil/ble-split*
+ ;; (expt 2 13) ***
+ 8192)
+
+(define *ldil-factor*
+ ;; (/ *ldil/ble-split* ldil-scale)
+ 4)
+
+(define (declare-closure-pattern! pattern)
+ (add-extra-code!
+ (or (find-extra-code-block 'CLOSURE-PATTERNS)
+ (let ((section-label (generate-label))
+ (ev-label (generate-label)))
+ (let ((block (declare-extra-code-block!
+ 'CLOSURE-PATTERNS
+ 'LAST
+ `(((/ (- ,ev-label ,section-label) 4)
+ . ,ev-label)))))
+ (add-extra-code! block
+ (LAP (LABEL ,section-label)))
+ block)))
+ (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*)
+ ,@pattern)))
+
+(define (generate-closure-entry offset pattern label min max)
+ (let ((entry-label (rtl-procedure/external-label (label->object label))))
+ (LAP (USHORT ()
+ ,(make-procedure-code-word min max)
+ ,(quotient offset 2))
+ ;; This contains an offset -- the linker turns it to an abs. addr.
+ (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label)
+ ,*ldil/ble-split*)
+ ,*ldil-factor*)
+ 26)
+ (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label)
+ ,*ldil/ble-split*)
+ 5 26))
+ (ADDI () -15 31 25))))
+
+(define (cons-closure target entry-label min max size)
+ (let ((offset 8)
+ (total-size (+ size closure-entry-size))
+ (pattern (generate-label)))
+
+ (declare-closure-pattern!
+ (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label))
+ (LABEL ,pattern)
+ (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
+ total-size))
+ ,@(generate-closure-entry offset pattern entry-label min max)))
+ #|
+ ;; This version uses ordinary integer instructions
+
+ (let* ((offset* (* 4 (1+ closure-entry-size)))
+ (target (standard-target! target))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!))
+ (temp3 (standard-temporary!)))
+
+ (LAP ,@(load-pc-relative-address pattern target 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp3)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer))
+\f
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target)
+ (FDC () (INDEX 0 0 ,target))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))
+ |#
+
+ #|
+ ;; This version is faster by using floating-point (doubleword) moves
+
+ (let* ((offset* (* 4 (1+ closure-entry-size)))
+ (target (standard-target! target))
+ (dwtemp1 (flonum-temporary!))
+ (dwtemp2 (flonum-temporary!))
+ (swtemp (standard-temporary!)))
+
+ (LAP ,@(load-pc-relative-address pattern target 'CODE)
+ (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
+ (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp)
+ (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1)
+ (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer))
+ (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2)
+ (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
+ (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer)
+ ,target)
+ (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
+ (FDC () (INDEX 0 0 ,target))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))
+ |#
+
+ ;; This version does the copy out of line, using fp instructions.
+
+ (let* ((hook-label (generate-label))
+ (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
+ #| regnum:addil-result |#
+ regnum:ble-return)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target g25)
+ (LAP ,@flush-reg
+ ,@(invoke-hook hook:compiler-copy-closure-pattern)
+ (LABEL ,hook-label)
+ (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))))
+\f
+(define (cons-multiclosure target nentries size entries)
+ ;; nentries > 1
+ (let ((offset 12)
+ (total-size (+ (+ 1 (* closure-entry-size nentries)) size))
+ (pattern (generate-label)))
+
+ (declare-closure-pattern!
+ (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries)))
+ (LABEL ,pattern)
+ (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
+ total-size))
+ (USHORT () ,nentries 0)
+ ,@(let make-entries ((entries entries)
+ (offset offset))
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP ,@(generate-closure-entry offset
+ pattern
+ (car entry)
+ (cadr entry)
+ (caddr entry))
+ ,@(make-entries (cdr entries)
+ (+ offset
+ (* 4 closure-entry-size)))))))))
+ #|
+ ;; This version uses ordinary integer instructions
+
+ (let ((target (standard-target! target)))
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!))
+ (ctr (standard-temporary!))
+ (srcptr (standard-temporary!))
+ (index (standard-temporary!))
+ (loop-label (generate-label)))
+
+ (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target)
+ (LDI () -16 ,index)
+ (LDI () ,nentries ,ctr)
+ ;; The loop copies 16 bytes, and the architecture specifies
+ ;; that a cache line must be a multiple of this value.
+ ;; Therefore we only need to flush once per loop,
+ ;; and once more (D only) to take care of phase.
+ (LABEL ,loop-label)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+ (SYNC ())
+ (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label))
+ (FIC () (INDEX ,index 5 ,regnum:free-pointer))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,regnum:free-pointer))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer))))
+ |#
+\f
+ #|
+ ;; This version is faster by using floating-point (doubleword) moves
+
+ (let ((target (standard-target! target)))
+ (let ((dwtemp1 (flonum-temporary!))
+ (dwtemp2 (flonum-temporary!))
+ (temp (standard-temporary!))
+ (ctr (standard-temporary!))
+ (srcptr (standard-temporary!))
+ (index (standard-temporary!))
+ (loop-label (generate-label)))
+
+ (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
+ (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
+ (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target)
+ (LDI () -16 ,index)
+ (LDI () ,nentries ,ctr)
+
+ ;; The loop copies 16 bytes, and the architecture specifies
+ ;; that a cache line must be a multiple of this value.
+ ;; Therefore we only need to flush (D) once per loop,
+ ;; and once more to take care of phase.
+ ;; We only need to flush the I cache once because it is
+ ;; newly allocated memory.
+
+ (LABEL ,loop-label)
+ (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1)
+ (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2)
+ (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
+ (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
+ (ADDIB (>) -1 ,ctr (@PCR ,loop-label))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
+ (LDI () ,(* -4 (1+ size)) ,index)
+ (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ()))))
+ |#
+
+ ;; This version does the copy out of line, using fp instructions.
+
+ (let* ((hook-label (generate-label))
+ (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
+ #| regnum:addil-result |#
+ regnum:ble-return)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target g25)
+ (LAP ,@flush-reg
+ (LDI () ,nentries 1)
+ ,@(invoke-hook hook:compiler-copy-multiclosure-pattern)
+ (LABEL ,hook-label)
+ (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))))
\f
;;;; Entry Header
;;; This is invoked by the top level of the LAP generator.
(define (generate/constants-block constants references assignments
uuo-links global-links static-vars)
(let ((constant-info
- ;; Note: generate/remote-links depends on all the references (& uuos)
- ;; being first!
+ ;; Note: generate/remote-links depends on all the linkage sections
+ ;; (references & uuos) being first!
(declare-constants 0 (transmogrifly uuo-links)
(declare-constants 1 references
(declare-constants 2 assignments
(declare-constants 3 (transmogrifly global-links)
- (declare-constants false
- (map (lambda (pair)
- (cons false (cdr pair)))
- static-vars)
- (declare-constants false constants
- (cons false (LAP))))))))))
+ (declare-closure-patterns
+ (declare-constants false (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (declare-constants false constants
+ (cons false (LAP)))))))))))
(let ((free-ref-label (car constant-info))
(constants-code (cdr constant-info))
(debugging-information-label (allocate-constant-label))
(+ (if (null? uuo-links) 0 1)
(if (null? references) 0 1)
(if (null? assignments) 0 1)
- (if (null? global-links) 0 1))))
+ (if (null? global-links) 0 1)
+ (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1))))
(values
(LAP ,@constants-code
;; Place holder for the debugging info filename
environment-label
free-ref-label
n-sections))))
+\f
+(define (declare-constants/tagged tag header constants info)
+ (define-integrable (wrap tag label value)
+ (LAP (,tag ,label ,value)))
-(define (declare-constants tag constants info)
(define (inner constants)
(if (null? constants)
(cdr info)
(let ((entry (car constants)))
- (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+ (LAP ,@(wrap tag (cdr entry) (car entry))
,@(inner (cdr constants))))))
- (if (and tag (not (null? constants)))
+
+ (if (and header (not (null? constants)))
(let ((label (allocate-constant-label)))
(cons label
- (inner
- `((,(let ((datum (length constants)))
- (if (> datum #xffff)
- (error "datum too large" datum))
- (+ (* tag #x10000) datum))
- . ,label)
- ,@constants))))
+ (LAP (SCHEME-OBJECT
+ ,label
+ ,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* header #x10000) datum)))
+ ,@(inner constants))))
(cons (car info) (inner constants))))
+(define (declare-constants header constants info)
+ (declare-constants/tagged 'SCHEME-OBJECT header constants info))
+
+(define (declare-closure-patterns info)
+ (let ((block (find-extra-code-block 'CLOSURE-PATTERNS)))
+ (if (not block)
+ info
+ (declare-constants/tagged 'SCHEME-EVALUATION
+ 4
+ (extra-code-block/xtra block)
+ info))))
+
+(define (declare-evaluations header evals info)
+ (declare-constants/tagged 'SCHEME-EVALUATION header evals info))
+
(define (transmogrifly uuos)
(define (inner name assoc)
(if (null? assoc)
#| -*-Scheme-*-
-$Id: rulflo.scm,v 4.38 1993/07/01 07:48:28 gjr Exp $
+$Id: rulflo.scm,v 4.39 1993/12/08 17:50:21 gjr Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
(LAP ,@(object->address source)
(FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target)))))
+;; This is endianness dependent!
+
+(define (flonum-value->data-decl value)
+ (let ((high (make-bit-string 32 false))
+ (low (make-bit-string 32 false)))
+ (read-bits! value 32 high)
+ (read-bits! value 64 low)
+ (LAP ,@(lap:comment `(FLOAT ,value))
+ (UWORD () ,(bit-string->unsigned-integer high))
+ (UWORD () ,(bit-string->unsigned-integer low)))))
+
+(define (flonum->label value)
+ (let* ((block
+ (or (find-extra-code-block 'FLOATING-CONSTANTS)
+ (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS
+ 'ANYWHERE
+ '())))
+ (add-extra-code!
+ block
+ (LAP (PADDING ,(- 0 *initial-dword-offset*) 8)))
+ block)))
+ (pairs (extra-code-block/xtra block))
+ (place (assoc value pairs)))
+ (if place
+ (cdr place)
+ (let ((label (generate-label)))
+ (set-extra-code-block/xtra!
+ block
+ (cons (cons value label) pairs))
+ (add-extra-code! block
+ (LAP (LABEL ,label)
+ ,@(flonum-value->data-decl value)))
+ label))))
+\f
+#|
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.)))
(LAP (FCPY (DBL) 0 ,(flonum-target! target))))
+|#
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
+ (cond ((not (flo:flonum? fp-value))
+ (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
+ (compiler:cross-compiling?
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-constant fp-value temp)
+ ,@(object->address temp)
+ (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target)))))
+ ((flo:= fp-value 0.0)
+ (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
+ (else
+ (let* ((temp (standard-temporary!))
+ (target (flonum-target! target)))
+ (LAP ,@(load-pc-relative-address (flonum->label fp-value)
+ temp
+ 'CONSTANT)
+ (FLDDS () (OFFSET 0 0 ,temp) ,target))))))
(define-rule statement
(ASSIGN (REGISTER (? target))
projects / mit-scheme.git / commitdiff