--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Interrupt Checks
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;; The first two procedures are the interface.
+;; GET-EXIT-INTERRUPT-CHECKS and GET-ENTRY-INTERRUPT-CHECKS get a list
+;; of kinds interrupt check. An empty list implies no check is
+;; required. The list can contain these symbols:
+;;
+;; STACK stack check required here
+;; HEAP heap check required here
+;; INTERRUPT check required here to avoid loops without checks.
+;;
+;; The traversal and decision making is done immediately prior to LAP
+;; generation (from PRE-LAPGEN-ANALYSIS.)
+
+(define (get-entry-interrupt-checks)
+ (get-interupt-checks 'ENTRY-INTERRUPT-CHECKS))
+
+(define (get-exit-interrupt-checks)
+ (get-interupt-checks 'EXIT-INTERRUPT-CHECKS))
+
+(define (expect-no-entry-interrupt-checks)
+ (if (not (null? (get-entry-interrupt-checks)))
+ (error "No entry interrupt checks expected here" *current-bblock*)))
+
+(define (expect-no-exit-interrupt-checks)
+ (if (not (null? (get-exit-interrupt-checks)))
+ (error "No exit interrupt checks expected here" *current-bblock*)))
+
+(define (get-interupt-checks kind)
+ (or (cfg-node-get *current-bblock* kind)
+ (error "DETERMINE-INTERRUPT-CHECKS failed" kind)))
+
+;; This algorithm finds leaf-procedure-like paths in the rtl control
+;; flow graph. If a procedure entry point can only reach a return, it
+;; is leaf-like. If a return can only be reached from a procedure
+;; entry, it too is leaf-like.
+;;
+;; If a procedure reaches a procedure call, that could be a loop, so
+;; it is not leaf-like. Similarly, if a continuation entry reaches
+;; return, that could be a long unwinding of recursion, so a check is
+;; needed in case the unwinding does allocation.
+;;
+;; Typically, true leaf procedures avoid both checks, and trivial
+;; cases (like MAP returning '()) avoid the exit check.
+;;
+;; This could be a lot smarter. For example, a procedure entry does
+;; not need to check for interrupts if it reaches call sites of
+;; strictly lesser arity; or it could analyze the cycles in the CFG
+;; and select good places to break them
+;;
+;; The algorithm has three phases: (1) explore the CFG to find all
+;; entry and exit points, (2) propagate entry (exit) information so
+;; that each potential interrupt check point knows what kinds of exits
+;; (entrys) it reaches (is reached from), and (3) decide on the kinds
+;; of interrupt check that are required at each entry and exit.
+\f
+(define (determine-interrupt-checks bblock)
+ (let ((entries '())
+ (exits '()))
+
+ (define (explore bblock)
+ (or (cfg-node-get bblock 'INTERRUPT-CHECK-EXPLORE)
+ (begin
+ (cfg-node-put! bblock 'INTERRUPT-CHECK-EXPLORE #T)
+ (if (node-previous=0? bblock)
+ (set! entries (cons bblock entries))
+ (if (rtl:continuation-entry?
+ (rinst-rtl (bblock-instructions bblock)))
+ ;; previous block is invocation:special-primitive
+ ;; so it is just an out of line instruction
+ (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS '())))
+ (for-each-previous-node bblock explore)
+ (for-each-subsequent-node bblock explore)
+ (if (and (snode? bblock)
+ (or (not (snode-next bblock))
+ (let ((last (last-insn bblock)))
+ (or (rtl:invocation:special-primitive? last)
+ (rtl:invocation:primitive? last)))))
+ (set! exits (cons bblock exits))))))
+
+ (define (for-each-subsequent-node node procedure)
+ (if (snode? node)
+ (if (snode-next node)
+ (procedure (snode-next node)))
+ (begin
+ (procedure (pnode-consequent node))
+ (procedure (pnode-alternative node)))))
+
+ (define (propagator for-each-link)
+ (lambda (node update place)
+ (let propagate ((node node))
+ (let ((old (cfg-node-get node place)))
+ (let ((new (update old)))
+ (if (not (equal? old new))
+ (begin
+ (cfg-node-put! node place new)
+ (for-each-link node propagate))))))))
+
+ (define upward (propagator for-each-previous-node))
+ (define downward (propagator for-each-subsequent-node))
+
+ (define (setting-flag old) old #T)
+
+ (define (propagate-entry-info bblock)
+ (let ((insn (rinst-rtl (bblock-instructions bblock))))
+ (cond ((or (rtl:continuation-entry? insn)
+ (rtl:continuation-header? insn))
+ (downward bblock setting-flag 'REACHED-FROM-CONTINUATION))
+ ((or (rtl:closure-header? insn)
+ (rtl:ic-procedure-header? insn)
+ (rtl:open-procedure-header? insn)
+ (rtl:procedure-header? insn))
+ (downward bblock setting-flag 'REACHED-FROM-PROCEDURE))
+ (else unspecific))))
+
+ (define (propagate-exit-info exit-bblock)
+ (let ((insn (last-insn exit-bblock)))
+ (cond ((rtl:pop-return? insn)
+ (upward exit-bblock setting-flag 'REACHES-POP-RETURN))
+ (else
+ (upward exit-bblock setting-flag 'REACHES-INVOCATION)))))
+\f
+ (define (decide-entry-checks bblock)
+ (define (checks! types)
+ (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS types))
+ (define (decide-label internal-label)
+ (let ((object (label->object internal-label)))
+ (let ((stack?
+ (if (and (rtl-procedure? object)
+ (not (rtl-procedure/stack-leaf? object))
+ compiler:generate-stack-checks?)
+ '(STACK)
+ '())))
+ (if (or (cfg-node-get bblock 'REACHES-INVOCATION)
+ (pair? stack?))
+ (checks! (cons* 'HEAP 'INTERRUPT stack?))
+ (checks! '())))))
+
+ (let ((insn (rinst-rtl (bblock-instructions bblock))))
+ (cond ((rtl:continuation-entry? insn) (checks! '()))
+ ((rtl:continuation-header? insn) (checks! '()))
+ ((rtl:closure-header? insn)
+ (decide-label (rtl:closure-header-procedure insn)))
+ ((rtl:ic-procedure-header? insn)
+ (decide-label (rtl:ic-procedure-header-procedure insn)))
+ ((rtl:open-procedure-header? insn)
+ (decide-label (rtl:open-procedure-header-procedure insn)))
+ ((rtl:procedure-header? insn)
+ (decide-label (rtl:procedure-header-procedure insn)))
+ (else
+ (checks! '(INTERRUPT))))))
+
+ (define (last-insn bblock)
+ (rinst-rtl (rinst-last (bblock-instructions bblock))))
+
+ (define (decide-exit-checks bblock)
+ (define (checks! types)
+ (cfg-node-put! bblock 'EXIT-INTERRUPT-CHECKS types))
+ (if (rtl:pop-return? (last-insn bblock))
+ (if (cfg-node-get bblock 'REACHED-FROM-CONTINUATION)
+ (checks! '(INTERRUPT))
+ (checks! '()))
+ (checks! '())))
+
+ (explore bblock)
+
+ (for-each propagate-entry-info entries)
+ (for-each propagate-exit-info exits)
+ (for-each decide-entry-checks entries)
+ (for-each decide-exit-checks exits)))
\ No newline at end of file
;;;; Register-Allocator Interface
(define available-machine-registers
- ;; esp holds the the stack pointer
- ;; ebp holds the pointer mask
- ;; esi holds the register array pointer
- ;; edi holds the free pointer
+ ;; rsp holds the the stack pointer
+ ;; rbp holds the pointer mask
+ ;; rsi holds the register array pointer
+ ;; rdi holds the free pointer
+ ;++ float
;; fr7 is not used so that we can always push on the stack once.
- (list eax ecx edx ebx fr0 fr1 fr2 fr3 fr4 fr5 fr6))
+ (list rax rcx rdx rbx r8 r9 r10 r11 r12 r13 r14 r15
+ ;++ float
+ ;; fr0 fr1 fr2 fr3 fr4 fr5 fr6
+ ;; mmx0 mmx1 mmx2 mmx3 mmx4 mmx5 mmx6 mmx7
+ ;; xmm0 xmm1 xmm2 xmm3 xmm4 xmm5 xmm6 xmm7
+ ;; xmm8 xmm9 xmm10 xmm11 xmm12 xmm13 xmm14 xmm15
+ ))
+(define (sort-machine-registers registers)
+ registers)
+
+;++ float
+
+#;
(define (sort-machine-registers registers)
;; FR0 is preferable to other FPU regs. We promote it to the front
;; if we find another FPU reg in front of it.
(cond ((machine-register? register)
(vector-ref
'#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
- FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ ;++ float
+ ;; FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT ;x87 fp
+ ;; FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT ;MMX 64bit
+ ;; MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA ;XMM 128bit
+ ;; MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA MEDIA
+ )
register))
((register-value-class=word? register)
'GENERAL)
((register-value-class=float? register)
'FLOAT)
(else
- (error "unable to determine register type" register))))
-
+ (error "Unable to determine register type:" register))))
+\f
(define register-reference
(let ((references (make-vector number-of-machine-registers)))
- (let loop ((i 0))
- (cond ((>= i number-of-machine-registers)
- (lambda (register)
- (vector-ref references register)))
- ((< i 8)
- (vector-set! references i (INST-EA (R ,i)))
- (loop (1+ i)))
- (else
- (vector-set! references i (INST-EA (ST ,(floreg->sti i))))
- (loop (1+ i)))))))
+ (do ((i rax (+ i 1)))
+ ((> i r15))
+ (vector-set! references i (INST-EA (R ,i))))
+ ;++ float
+ ;; (do ((i fr0 (+ i 1)))
+ ;; ((>= i fr7))
+ ;; (vector-set! references i (INST-EA (ST ,(floreg->sti i)))))
+ ;; (do ((i mmx0 (+ i 1)))
+ ;; ((>= i mmx7))
+ ;; (vector-set! references i (INST-EA (MMX ...))))
+ ;; (do ((i xmm0 (+ i 1)))
+ ;; ((>= i xmm15))
+ ;; (vector-set! references i (INST-EA (XMM ...))))
+ (lambda (register)
+ (vector-ref references register))))
(define (register->register-transfer source target)
(machine->machine-register source target))
(define (reference->register-transfer source target)
(cond ((equal? (register-reference target) source)
(LAP))
+ ;++ float
((float-register-reference? source)
;; Assume target is a float register
(LAP (FLD ,source)))
(define (register->home-transfer source target)
(machine->pseudo-register source target))
+;++ float
+
(define-integrable (float-register-reference? ea)
+ ea
+ #f
+ #;
(and (pair? ea)
(eq? (car ea) 'ST)))
\f
(define-integrable (machine->machine-register source target)
(guarantee-registers-compatible source target)
+ ;++ float
(if (not (float-register? source))
- (LAP (MOV W ,(register-reference target) ,(register-reference source)))
+ (LAP (MOV Q ,(register-reference target) ,(register-reference source)))
(let ((ssti (floreg->sti source))
(tsti (floreg->sti target)))
(if (zero? ssti)
(FSTP (ST ,(1+ tsti))))))))
(define (machine-register->memory source target)
+ ;++ float
(if (not (float-register? source))
- (LAP (MOV W ,target ,(register-reference source)))
+ (LAP (MOV Q ,target ,(register-reference source)))
(let ((ssti (floreg->sti source)))
(if (zero? ssti)
(LAP (FST D ,target))
(FSTP D ,target))))))
(define (memory->machine-register source target)
+ ;++ float
(if (not (float-register? target))
- (LAP (MOV W ,(register-reference target) ,source))
+ (LAP (MOV Q ,(register-reference target) ,source))
(LAP (FLD D ,source)
(FSTP (ST ,(1+ (floreg->sti target)))))))
+(define-integrable (offset-referenceable? offset)
+ (byte-offset-referenceable? (* address-units-per-object offset)))
+
(define-integrable (offset-reference register offset)
- (byte-offset-reference register (* 4 offset)))
+ (byte-offset-reference register (* address-units-per-object offset)))
+
+(define-integrable (byte-offset-referenceable? offset)
+ (fits-in-signed-long? offset))
(define (byte-offset-reference register offset)
(cond ((zero? offset)
(INST-EA (@R ,register)))
((fits-in-signed-byte? offset)
(INST-EA (@RO B ,register ,offset)))
+ ;; Assume that we are in 32-bit mode or in 64-bit mode, in
+ ;; which case (@RO W ...) doesn't work.
+ ;; ((fits-in-signed-word? offset)
+ ;; (INST-EA (@RO W ,register ,offset)))
+ ((fits-in-signed-long? offset)
+ (INST-EA (@RO L ,register ,offset)))
(else
- (INST-EA (@RO W ,register ,offset)))))
+ (error "Offset too large:" offset))))
+
+(define-integrable (byte-unsigned-offset-referenceable? offset)
+ (byte-offset-referenceable? offset))
(define (byte-unsigned-offset-reference register offset)
- (cond ((zero? offset)
- (INST-EA (@R ,register)))
- ((fits-in-unsigned-byte? offset)
- (INST-EA (@RO UB ,register ,offset)))
- (else
- (INST-EA (@RO UW ,register ,offset)))))
+ (if (< offset 0)
+ (error "Negative unsigned offset:" offset))
+ ;; We don't have unsigned addressing modes.
+ (byte-offset-reference register offset))
+\f
+;++ This computation is probably not quite right.
(define-integrable (pseudo-register-offset register)
- (+ (+ (* 16 4) (* 80 4))
+ (+ (+ (* 16 address-units-per-object) (* 80 address-units-per-object))
(* 3 (register-renumber register))))
(define-integrable (pseudo->machine-register source target)
(define-integrable (machine->pseudo-register source target)
(machine-register->memory source (pseudo-register-home target)))
+;++ float
+
+(define (general-register? register)
+ register
+ #t)
+
+(define (float-register? register)
+ register
+ #f)
+
+(define (floreg->sti reg)
+ (error "x87 floating-point not supported:" `(FLOREG->STI ,reg)))
+
+#|
(define-integrable (floreg->sti reg)
(- reg fr0))
(define-integrable (float-register? register)
(<= fr0 register fr7))
+|#
\f
;;;; Utilities for the rules
(define (object->machine-register! object mreg)
;; This funny ordering allows load-constant to use a pc value in mreg!
- (let ((code (load-constant (INST-EA (R ,mreg)) object)))
+ ;; [TRC 20091025: Does this matter, given PC-relative addressing?]
+ (let ((code (load-constant->register (INST-EA (R ,mreg)) object)))
(require-register! mreg)
code))
(move-to-alias-register! source (register-type target) target)
(LAP))
-(define (convert-object/constant->register target constant conversion)
- (delete-dead-registers!)
- (let ((target (target-register-reference target)))
- (if (non-pointer-object? constant)
- ;; Is this correct if conversion is object->address ?
- (load-non-pointer target 0 (careful-object-datum constant))
- (LAP ,@(load-constant target constant)
- ,@(conversion target)))))
-
-(define (non-pointer->literal object)
- (make-non-pointer-literal (object-type object)
- (careful-object-datum object)))
-
-(define (load-immediate target value)
- (if (zero? value)
- (LAP (XOR W ,target ,target))
- (LAP (MOV W ,target (& ,value)))))
-
-(define (load-non-pointer target type datum)
- (let ((immediate-value (make-non-pointer-literal type datum)))
- (if (zero? immediate-value)
- (LAP (XOR W ,target ,target))
- (LAP (MOV W ,target (&U ,immediate-value))))))
-
-(define (load-constant target obj)
- (if (non-pointer-object? obj)
- (load-non-pointer target (object-type obj) (careful-object-datum obj))
- (load-pc-relative target (constant->label obj))))
-
(define (load-pc-relative target label-expr)
- (with-pc
- (lambda (pc-label pc-register)
- (LAP (MOV W ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
+ (LAP (MOV Q ,target (@PCR ,label-expr))))
(define (load-pc-relative-address target label-expr)
- (with-pc
- (lambda (pc-label pc-register)
- (LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
-\f
-(define (with-pc recvr)
- (with-values (lambda () (get-cached-label))
- (lambda (label reg)
- (if label
- (recvr label reg)
- (let ((temporary (allocate-temporary-register! 'GENERAL)))
- (pc->reg temporary
- (lambda (label prefix)
- (cache-label! label temporary)
- (LAP ,@prefix
- ,@(recvr label temporary)))))))))
-
-(define (pc->reg reg recvr)
- (let ((label (generate-label 'GET-PC)))
- (recvr label
- (LAP (CALL (@PCR ,label))
- (LABEL ,label)
- (POP ,(register-reference reg))))))
-
-(define-integrable (get-cached-label)
- (register-map-label *register-map* 'GENERAL))
-
-(define-integrable (cache-label! label temporary)
- (set! *register-map*
- (set-machine-register-label *register-map* temporary label))
- unspecific)
+ (LAP (LEA Q ,target (@PCR ,label-expr))))
(define (compare/register*register reg1 reg2)
(cond ((register-alias reg1 'GENERAL)
=>
(lambda (alias)
- (LAP (CMP W ,(register-reference alias) ,(any-reference reg2)))))
+ (LAP (CMP Q ,(register-reference alias) ,(any-reference reg2)))))
((register-alias reg2 'GENERAL)
=>
(lambda (alias)
- (LAP (CMP W ,(any-reference reg1) ,(register-reference alias)))))
+ (LAP (CMP Q ,(any-reference reg1) ,(register-reference alias)))))
(else
- (LAP (CMP W ,(source-register-reference reg1)
+ (LAP (CMP Q ,(source-register-reference reg1)
,(any-reference reg2))))))
+
+(define (compare/reference*non-pointer register non-pointer)
+ (compare/reference*literal register (non-pointer->literal non-pointer)))
+
+(define (compare/reference*literal reference literal)
+ (if (fits-in-signed-long? literal)
+ (LAP (CMP Q ,reference (&U ,literal)))
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV Q ,temp (&U ,literal))
+ (CMP Q ,reference ,temp)))))
+\f
+;;;; Literals and Constants
+
+;;; These are slightly tricky because most instructions don't admit
+;;; 64-bit operands.
+
+(define (convert-object/constant->register target object conversion)
+ (let ((target (target-register-reference target)))
+ (if (non-pointer-object? object)
+ ;; Is this correct if conversion is object->address ?
+ (load-non-pointer-constant->register target object)
+ (LAP ,@(load-pointer-constant->register target object)
+ ,@(conversion target)))))
+
+(define (load-constant->register register object)
+ (if (non-pointer-object? object)
+ (load-non-pointer-constant->register register object)
+ (load-pointer-constant->register register object)))
+
+(define (load-pointer-constant->register register object)
+ (LAP (MOV Q ,register (@PCR ,(constant->label object)))))
+
+(define (load-non-pointer-constant->register register object)
+ (load-non-pointer-literal->register register (non-pointer->literal object)))
+
+(define (load-non-pointer-constant->offset register object)
+ (load-non-pointer-literal->offset register (non-pointer->literal object)))
+
+(define (load-non-pointer->register register type datum)
+ (load-non-pointer-literal->register register
+ (make-non-pointer-literal type datum)))
+
+(define (load-non-pointer->offset register type datum)
+ (load-non-pointer-literal->offset register
+ (make-non-pointer-literal type datum)))
+
+(define (load-non-pointer-literal->register register literal)
+ (load-unsigned-immediate->register register literal))
+
+(define (load-non-pointer-literal->offset register literal)
+ (load-unsigned-immediate->offset register literal))
+
+(define (non-pointer->literal object)
+ (make-non-pointer-literal (object-type object)
+ (careful-object-datum object)))
+\f
+(define (load-signed-immediate->register target immediate)
+ (cond ((zero? immediate)
+ (LAP (XOR Q ,target ,target)))
+ ((fits-in-signed-quad? immediate)
+ (LAP (MOV Q ,target (& ,immediate))))
+ (else
+ (error "Signed immediate too large:" immediate))))
+
+(define (load-unsigned-immediate->register target immediate)
+ (cond ((zero? immediate)
+ (LAP (XOR Q ,target ,target)))
+ ((fits-in-unsigned-quad? immediate)
+ (LAP (MOV Q ,target (&U ,immediate))))
+ (else
+ (error "Unsigned immediate too large:" immediate))))
+
+(define (load-signed-immediate->offset offset immediate)
+ (if (fits-in-signed-long? immediate)
+ (LAP (MOV Q ,(offset->reference! offset) (& ,immediate)))
+ (let* ((temporary (temporary-register-reference))
+ (target (offset->reference! offset)))
+ (LAP ,@(load-signed-immediate->register temporary immediate)
+ (MOV Q ,target ,temporary)))))
+
+(define (load-unsigned-immediate->offset offset immediate)
+ (if (fits-in-unsigned-long? immediate)
+ (LAP (MOV Q ,(offset->reference! offset) (&U ,immediate)))
+ (let* ((temporary (temporary-register-reference))
+ (target (offset->reference! offset)))
+ (LAP ,@(load-unsigned-immediate->register temporary immediate)
+ (MOV Q ,target ,temporary)))))
\f
(define (target-register target)
(delete-dead-registers!)
(lambda (temp)
(let ((tref (register-reference temp))
(ea (indexed-ea-mode base index scale b-offset)))
- (LAP (LEA ,tref ,ea)
+ (LAP (LEA Q ,tref ,ea)
,@(object->address tref)
,@(recvr (INST-EA (@R ,temp)))))))
(with-reused-temp
(define (indexed-ea-mode base index scale offset)
(cond ((zero? offset)
(INST-EA (@RI ,base ,index ,scale)))
- ((<= -128 offset 127)
+ ((fits-in-signed-byte? offset)
(INST-EA (@ROI B ,base ,offset ,index ,scale)))
+ ((fits-in-signed-long? offset)
+ (INST-EA (@ROI L ,base ,offset ,index ,scale)))
(else
- (INST-EA (@ROI W ,base ,offset ,index ,scale)))))
+ (error "Offset too large:" offset))))
\f
(define (rtl:simple-offset? expression)
(and (rtl:offset? expression)
(cond ((not (rtl:register? base))
(indexed-ea (rtl:register-number (rtl:offset-address-base base))
(rtl:register-number (rtl:offset-address-offset base))
- 4
- (* 4 (rtl:machine-constant-value offset))))
+ address-units-per-object
+ (* address-units-per-object
+ (rtl:machine-constant-value offset))))
((rtl:machine-constant? offset)
(indirect-reference! (rtl:register-number base)
(rtl:machine-constant-value offset)))
(else
(indexed-ea (rtl:register-number base)
(rtl:register-number offset)
- 4
+ address-units-per-object
0)))))
(define (rtl:simple-byte-offset? expression)
(define (float-offset->reference! offset)
;; OFFSET must be a simple float offset
(let ((base (rtl:float-offset-base offset))
- (offset (rtl:float-offset-offset offset)))
+ (offset (rtl:float-offset-offset offset))
+ (objects-per-float
+ (quotient address-units-per-float address-units-per-object)))
(cond ((not (rtl:register? base))
(let ((base*
(rtl:register-number (rtl:offset-address-base base)))
(if (rtl:machine-constant? offset)
(indirect-reference!
base*
- (+ (* 2 (rtl:machine-constant-value offset))
+ (+ (* objects-per-float (rtl:machine-constant-value offset))
w-offset))
(indexed-ea base*
(rtl:register-number offset)
- 8
- (* 4 w-offset)))))
+ address-units-per-float
+ (* address-units-per-object w-offset)))))
((rtl:machine-constant? offset)
(indirect-reference! (rtl:register-number base)
- (* 2 (rtl:machine-constant-value offset))))
+ (* objects-per-float
+ (rtl:machine-constant-value offset))))
(else
(indexed-ea (rtl:register-number base)
(rtl:register-number offset)
- 8
+ address-units-per-object
0)))))
\f
(define (object->type target)
- (LAP (SHR W ,target (& ,scheme-datum-width))))
+ (LAP (SHR Q ,target (&U ,scheme-datum-width))))
(define (object->datum target)
- (LAP (AND W ,target (R ,regnum:datum-mask))))
+ (LAP (AND Q ,target (R ,regnum:datum-mask))))
(define (object->address target)
(declare (integrate-operator object->datum))
(load-machine-register! (rtl:register-number expression) register))
((CONS-POINTER)
(LAP ,@(clear-registers! register)
- ,@(load-non-pointer (rtl:machine-constant-value
- (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression))
- target)))
+ ,@(load-non-pointer->register
+ target
+ (rtl:machine-constant-value (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression)))))
((OFFSET)
(let ((source-reference (offset->reference! expression)))
(LAP ,@(clear-registers! register)
- (MOV W ,target ,source-reference))))
+ (MOV Q ,target ,source-reference))))
(else
(error "Unknown expression type" (car expression))))))
\f
(LAP (CALL ,entry)))
(define-integrable (invoke-interface code)
- (LAP (MOV B (R ,eax) (& ,code))
+ (LAP (MOV B (R ,rax) (& ,code))
,@(invoke-hook entry:compiler-scheme-to-interface)))
(define-integrable (invoke-interface/call code)
- (LAP (MOV B (R ,eax) (& ,code))
+ (LAP (MOV B (R ,rax) (& ,code))
,@(invoke-hook/call entry:compiler-scheme-to-interface/call)))
\f
+;++ This uses a kludge to number entries by byte offsets from the
+;++ registers block, but that works only in the 32-bit i386 version;
+;++ for x86-64 version, all the entries' byte indices exceed the range
+;++ of signed bytes. But this works for now.
+
(define-syntax define-entries
(sc-macro-transformer
(lambda (form environment)
(cons `(DEFINE-INTEGRABLE
,(symbol-append 'ENTRY:COMPILER-
(car names))
- (byte-offset-reference regnum:regs-pointer
+ (BYTE-OFFSET-REFERENCE REGNUM:REGS-POINTER
,index))
- (loop (cdr names) (+ index 4) high))
+ (loop (cdr names) (+ index 8) high))
(begin
(warn "define-entries: Too many for byte offsets.")
(loop names index (+ high 32000))))
'()))))))
-(define-entries #x40 #x80 ; (* 16 4)
+(define-entries #x80 #x100 ; (* 16 8)
scheme-to-interface ; Main entry point (only one necessary)
scheme-to-interface/call ; Used by rules3&4, for convenience.
trampoline-to-interface ; Used by trampolines, for convenience.
primitive-error
short-primitive-apply)
-(define-entries #x-80 0
+(define-entries #x-100 0
&+
&-
&*
(for-each (lambda (rgraph)
(for-each (lambda (edge)
(determine-interrupt-checks (edge-right-node edge)))
- (rgraph-entry-edges rgraph)))
- rgraphs))
\ No newline at end of file
+ (rgraph-entry-edges rgraph)))
+ rgraphs))
\ No newline at end of file
(ASSIGN (REGISTER (? target))
(OFFSET-ADDRESS (REGISTER (? source))
(REGISTER (? index))))
- (load-indexed-register target source index 4))
+ (load-indexed-register target source index address-units-per-object))
(define-rule statement
(ASSIGN (REGISTER (? target))
(OFFSET-ADDRESS (REGISTER (? source))
(MACHINE-CONSTANT (? n))))
- (load-displaced-register target source (* 4 n)))
+ (load-displaced-register target source (* address-units-per-object n)))
(define-rule statement
(ASSIGN (REGISTER (? target))
(ASSIGN (REGISTER (? target))
(FLOAT-OFFSET-ADDRESS (REGISTER (? source))
(REGISTER (? index))))
- (load-indexed-register target source index 8))
+ (load-indexed-register target source index address-units-per-float))
(define-rule statement
(ASSIGN (REGISTER (? target))
(FLOAT-OFFSET-ADDRESS (REGISTER (? source))
(MACHINE-CONSTANT (? n))))
- (load-displaced-register target source (* 8 n)))
+ (load-displaced-register target source (* address-units-per-float n)))
(define-rule statement
;; This is an intermediate rule -- not intended to produce code.
(CONS-POINTER (MACHINE-CONSTANT (? type))
(OFFSET-ADDRESS (REGISTER (? source))
(MACHINE-CONSTANT (? n)))))
- (load-displaced-register/typed target source type (* 4 n)))
+ (load-displaced-register/typed target
+ source
+ type
+ (* address-units-per-object n)))
(define-rule statement
(ASSIGN (REGISTER (? target))
(ASSIGN (REGISTER (? target))
(CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
(let ((temp (standard-move-to-temporary! type)))
- (LAP (ROR W ,temp (&U ,scheme-type-width))
- (OR W ,(standard-move-to-target! datum target) ,temp))))
+ (LAP (ROR Q ,temp (&U ,scheme-type-width))
+ (OR Q ,(standard-move-to-target! datum target) ,temp))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
+ (if (zero? type)
+ (assign-register->register target datum)
+ (let* ((datum (source-register-reference datum))
+ (target (target-register-reference target)))
+ ;; We could use a single MOV instruction with a 64-bit
+ ;; immediate, most of whose bytes are zero, but this three-
+ ;; instruction sequence uses fewer bytes.
+ (LAP (MOV B ,target (&U ,type))
+ (SHL Q ,target (&U ,scheme-datum-width))
+ (OR Q ,target ,datum)))))
+
+#| This doesn't work because immediate operands aren't big enough to
+ fit the type tag.
(define-rule statement
(ASSIGN (REGISTER (? target))
(let ((literal (make-non-pointer-literal type 0)))
(define (three-arg source)
(let ((target (target-register-reference target)))
- (LAP (LEA ,target (@RO UW ,source ,literal)))))
+ (LAP (LEA Q ,target (@RO UL ,source ,literal)))))
(define (two-arg target)
- (LAP (OR W ,target (&U ,literal))))
+ (LAP (OR Q ,target (&U ,literal))))
(let ((alias (register-alias datum 'GENERAL)))
(cond ((not alias)
(two-arg (get-tgt))))
(else
(three-arg alias)))))))
+|#
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
;;;; Loading Constants
(define-rule statement
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (load-constant (target-register-reference target) source))
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? object)))
+ (load-constant->register (target-register-reference target) object))
(define-rule statement
(ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
- (load-immediate (target-register-reference target) n))
+ (load-signed-immediate->register (target-register-reference target) n))
(define-rule statement
(ASSIGN (REGISTER (? target))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (load-non-pointer (target-register-reference target) type datum))
+ (load-non-pointer->register (target-register-reference target) type datum))
(define-rule statement
(ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
(define-rule statement
(ASSIGN (REGISTER (? target)) (? expression rtl:simple-offset?))
(let ((source (offset->reference! expression)))
- (LAP (MOV W ,(target-register-reference target) ,source))))
+ (LAP (MOV Q ,(target-register-reference target) ,source))))
(define-rule statement
(ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 4) 1))
- (LAP (POP ,(target-register-reference target))))
+ (LAP (POP Q ,(target-register-reference target))))
;;;; Transfers to Memory
(ASSIGN (? expression rtl:simple-offset?) (REGISTER (? r)))
(QUALIFIER (register-value-class=word? r))
(let ((source (source-register-reference r)))
- (LAP (MOV W
- ,(offset->reference! expression)
- ,source))))
+ (LAP (MOV Q ,(offset->reference! expression) ,source))))
(define-rule statement
- (ASSIGN (? expression rtl:simple-offset?) (CONSTANT (? value)))
- (QUALIFIER (non-pointer-object? value))
- (LAP (MOV W ,(offset->reference! expression)
- (&U ,(non-pointer->literal value)))))
+ (ASSIGN (? expression rtl:simple-offset?) (CONSTANT (? object)))
+ (QUALIFIER (non-pointer-object? object))
+ (load-non-pointer-constant->offset expression object))
(define-rule statement
(ASSIGN (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP (MOV W ,(offset->reference! expression)
- (&U ,(make-non-pointer-literal type datum)))))
+ (load-non-pointer->offset expression type datum))
(define-rule statement
(ASSIGN (? expression rtl:simple-offset?)
(MACHINE-CONSTANT (? n))))
(if (zero? n)
(LAP)
- (LAP (ADD W ,(offset->reference! expression) (& ,n)))))
+ (LAP (ADD Q ,(offset->reference! expression) (& ,n)))))
\f
;;;; Consing
+;;; rdi = 7, regnum:free-pointer
+
(define-rule statement
(ASSIGN (POST-INCREMENT (REGISTER 7) 1) (REGISTER (? r)))
(QUALIFIER (register-value-class=word? r))
- (LAP (MOV W (@R 7) ,(source-register-reference r))
- (ADD W (R 7) (& 4))))
+ (LAP (MOV Q (@R 7) ,(source-register-reference r))
+ (ADD Q (R 7) (&U ,address-units-per-object))))
;;;; Pushes
+;;; rsp = 4, regnum:stack-pointer
+
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (REGISTER (? r)))
(QUALIFIER (register-value-class=word? r))
- (LAP (PUSH ,(source-register-reference r))))
+ (LAP (PUSH Q ,(source-register-reference r))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 4) -1) (CONSTANT (? value)))
(QUALIFIER (non-pointer-object? value))
- (LAP (PUSH W (&U ,(non-pointer->literal value)))))
+ (push-non-pointer-literal (non-pointer->literal value)))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 4) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
- (LAP (PUSH W (&U ,(make-non-pointer-literal type datum)))))
+ (push-non-pointer-literal (make-non-pointer-literal type datum)))
+
+(define (push-non-pointer-literal literal)
+ (if (fits-in-unsigned-word? literal)
+ (LAP (PUSH Q (&U ,literal)))
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV Q ,temp (&U ,literal))
+ (PUSH Q ,temp)))))
\f
;;;; CHAR->ASCII/BYTE-OFFSET
(cond ((zero? n)
(assign-register->register target source))
((and (= target source)
- (= target esp))
- (if signed?
- (LAP (ADD W (R ,esp) (& ,n)))
- (LAP (ADD W (R ,esp) (&U ,n)))))
- (signed?
- (let* ((source (indirect-byte-reference! source n))
- (target (target-register-reference target)))
- (LAP (LEA ,target ,source))))
+ (= target rsp))
+ (let ((addend (if signed? (INST-EA (& ,n)) (INST-EA (&U ,n)))))
+ (if (fits-in-signed-long? n)
+ (LAP (ADD Q (R ,rsp) ,addend))
+ (begin
+ (need-register! rsp)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV Q ,temp ,addend)
+ (ADD Q (R ,rsp) ,temp)))))))
(else
- (let* ((source (indirect-unsigned-byte-reference! source n))
- (target (target-register-reference target)))
- (LAP (LEA ,target ,source))))))
+ (receive (reference! referenceable?)
+ (if signed?
+ (values indirect-byte-reference! byte-offset-referenceable?)
+ (values indirect-unsigned-byte-reference!
+ byte-unsigned-offset-referenceable?))
+ (define (with-address n suffix)
+ (let* ((source (reference! source n))
+ (target (target-register-reference target)))
+ (LAP (LEA Q ,target ,source)
+ ,@(suffix target))))
+ (if (referenceable? n)
+ (with-address n (lambda (target) target (LAP)))
+ (let ((division (integer-divide n #x80000000)))
+ (let ((q (integer-divide-quotient division))
+ (r (integer-divide-remainder division)))
+ (with-address r
+ (lambda (target)
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV Q ,temp (&U ,q))
+ (SHL Q ,temp (&U #x20))
+ (ADD Q ,target ,temp))))))))))))
(define-integrable (load-displaced-register target source n)
(load-displaced-register/internal target source n true))
(+ (make-non-pointer-literal type 0)
n))
false))
-
+\f
(define (load-indexed-register target source index scale)
(let* ((source (indexed-ea source index scale 0))
(target (target-register-reference target)))
- (LAP (LEA ,target ,source))))
+ (LAP (LEA Q ,target ,source))))
(define (load-pc-relative-address/typed target type label)
- (with-pc
- (lambda (pc-label pc-register)
- (LAP (LEA ,target (@RO UW
- ,pc-register
- (+ ,(make-non-pointer-literal type 0)
- (- ,label ,pc-label))))))))
+ ;++ This is pretty horrid, especially since it happens for every
+ ;++ continuation pushed! Neither alternative is much good.
+ ;; Twenty bytes.
+ (let ((temp (temporary-register-reference)))
+ (LAP (MOV Q ,temp (&U ,(make-non-pointer-literal type 0)))
+ (LEA Q ,target (@PCR ,label))
+ (OR Q ,target ,temp)))
+ #|
+ ;; Nineteen bytes.
+ (LAP (LEA Q ,target (@PCR ,label))
+ (SHL Q ,target (&U ,scheme-type-width))
+ (OR Q ,target (&U ,type))
+ (ROR Q ,target (&U ,scheme-type-width)))
+ |#
+ ;++ This doesn't work because CONSTANT->LABEL will give us a label
+ ;++ for the Scheme number object, not for the machine bit string.
+ #|
+ ;; Seventeen bytes -- but we need the label to work.
+ (let ((temp (temporary-register-reference))
+ (literal (make-non-pointer-literal type 0)))
+ (LAP (MOV Q ,temp (@PCR ,(constant->label literal)))
+ (LEA Q ,target (@PCR ,label))
+ (OR Q ,target ,temp)))
+ |#)
(define (load-char-into-register type source target)
(let ((target (target-register-reference target)))
;; No faster, but smaller
(LAP (MOVZX B ,target ,source)))
(else
- (LAP ,@(load-non-pointer target type 0)
+ (LAP ,@(load-non-pointer->register target type 0)
(MOV B ,target ,source))))))
(define (indirect-unsigned-byte-reference! register offset)
(? expression rtl:detagged-offset?))
(with-detagged-vector-location expression false
(lambda (temp)
- (LAP (MOV W ,(target-register-reference target) ,temp)))))
+ (LAP (MOV Q ,(target-register-reference target) ,temp)))))
(define-rule statement
(ASSIGN (? expression rtl:detagged-offset?)
(QUALIFIER (register-value-class=word? source))
(with-detagged-vector-location expression source
(lambda (temp)
- (LAP (MOV W ,temp ,(source-register-reference source))))))
+ (LAP (MOV Q ,temp ,(source-register-reference source))))))
(define (with-detagged-vector-location rtl-expression protect recvr)
(with-decoded-detagged-offset rtl-expression
(lambda (base index offset)
- (with-indexed-address base index 4 (* 4 offset) protect recvr))))
+ (with-indexed-address base index address-units-per-object
+ (* address-units-per-object offset)
+ protect
+ recvr))))
(define (rtl:detagged-offset? expression)
(and (rtl:offset? expression)
(define-rule predicate
(EQ-TEST (REGISTER (? register)) (? expression rtl:simple-offset?))
(set-equal-branches!)
- (LAP (CMP W ,(source-register-reference register)
+ (LAP (CMP Q ,(source-register-reference register)
,(offset->reference! expression))))
(define-rule predicate
(EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
(set-equal-branches!)
- (LAP (CMP W ,(offset->reference! expression)
+ (LAP (CMP Q ,(offset->reference! expression)
,(source-register-reference register))))
(define-rule predicate
(EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(any-reference register)
- (&U ,(non-pointer->literal constant)))))
+ (compare/reference*non-pointer (any-reference register) constant))
(define-rule predicate
(EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(any-reference register)
- (&U ,(non-pointer->literal constant)))))
+ (compare/reference*non-pointer (any-reference register) constant))
\f
(define-rule predicate
(EQ-TEST (CONSTANT (? constant)) (? expression rtl:simple-offset?))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(offset->reference! expression)
- (&U ,(non-pointer->literal constant)))))
+ (compare/reference*non-pointer (offset->reference! expression) constant))
(define-rule predicate
(EQ-TEST (? expression rtl:simple-offset?) (CONSTANT (? constant)))
(QUALIFIER (non-pointer-object? constant))
(set-equal-branches!)
- (LAP (CMP W ,(offset->reference! expression)
- (&U ,(non-pointer->literal constant)))))
+ (compare/reference*non-pointer (offset->reference! expression) constant))
(define-rule predicate
(EQ-TEST (CONSTANT (? constant-1)) (CONSTANT (? constant-2)))
(MACHINE-CONSTANT (? datum)))
(REGISTER (? register)))
(set-equal-branches!)
- (LAP (CMP W ,(any-reference register)
- (&U ,(make-non-pointer-literal type datum)))))
+ (compare/reference*literal (any-reference register)
+ (make-non-pointer-literal type datum)))
(define-rule predicate
(EQ-TEST (REGISTER (? register))
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
(set-equal-branches!)
- (LAP (CMP W ,(any-reference register)
- (&U ,(make-non-pointer-literal type datum)))))
+ (compare/reference*literal (any-reference register)
+ (make-non-pointer-literal type datum)))
(define-rule predicate
(EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum)))
(? expression rtl:simple-offset?))
(set-equal-branches!)
- (LAP (CMP W ,(offset->reference! expression)
- (&U ,(make-non-pointer-literal type datum)))))
+ (compare/reference*literal (offset->reference! expression)
+ (make-non-pointer-literal type datum)))
(define-rule predicate
(EQ-TEST (? expression rtl:simple-offset?)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(MACHINE-CONSTANT (? datum))))
(set-equal-branches!)
- (LAP (CMP W ,(offset->reference! expression)
- (&U ,(make-non-pointer-literal type datum)))))
+ (compare/reference*literal (offset->reference! expression)
+ (make-non-pointer-literal type datum)))
;; Combine tests for fixnum and non-negative by extracting the type
(REGISTER (? register)))
(let ((temp (standard-move-to-temporary! register)))
(set-equal-branches!)
- (LAP (SHR W ,temp (& ,(- scheme-datum-width 1)))
+ (LAP (SHR Q ,temp (&U ,(- scheme-datum-width 1)))
(CMP B ,temp (&U ,(* 2 (ucode-type fixnum)))))))
;; The type code needs to be cleared first.
(let ((checks (get-exit-interrupt-checks)))
(cond ((null? checks)
- (let ((bblock
- (make-new-sblock
- (LAP (POP (R ,eax)) ; continuation
- (AND W (R ,eax) (R ,regnum:datum-mask)) ; clear type
- (JMP (R ,eax))))))
- (current-bblock-continue! bblock)))
+ (current-bblock-continue!
+ (make-new-sblock
+ (LAP (POP Q (R ,rax)) ; continuation
+ (AND Q (R ,rax) (R ,regnum:datum-mask)) ; clear type
+ (JMP (R ,rax))))))
((block-association 'POP-RETURN)
=> current-bblock-continue!)
(else
(let ((bblock
(make-new-sblock
(let ((interrupt-label (generate-label 'INTERRUPT)))
- (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (LAP (CMP Q (R ,regnum:free-pointer) ,reg:compiled-memtop)
(JGE (@PCR ,interrupt-label))
- (POP (R ,eax)) ; continuation
- (AND W (R ,eax) (R ,regnum:datum-mask)) ; clear type
- (JMP (R ,eax))
+ (POP Q (R ,rax)) ; continuation
+ (AND Q (R ,rax) (R ,regnum:datum-mask)) ; clear type
+ (JMP (R ,rax))
(LABEL ,interrupt-label)
,@(invoke-hook
entry:compiler-interrupt-continuation-2))))))
continuation
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
- (POP (R ,ecx))
+ (POP Q (R ,rcx))
#|
- (MOV W (R ,edx) (& ,frame-size))
+ (MOV Q (R ,rdx) (&U ,frame-size))
,@(invoke-interface code:compiler-apply)
|#
,@(case frame-size
((7) (invoke-hook entry:compiler-shortcircuit-apply-size-7))
((8) (invoke-hook entry:compiler-shortcircuit-apply-size-8))
(else
- (LAP (MOV W (R ,edx) (& ,frame-size))
+ (LAP (MOV Q (R ,rdx) (&U ,frame-size))
,@(invoke-hook entry:compiler-shortcircuit-apply))))))
(define-rule statement
;; It expects the procedure at the top of the stack
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
- (POP (R ,eax))
- (AND W (R ,eax) (R ,regnum:datum-mask)) ;clear type code
- (JMP (R ,eax))))
+ (POP Q (R ,rax))
+ (AND Q (R ,rax) (R ,regnum:datum-mask)) ;clear type code
+ (JMP (R ,rax))))
\f
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation
(expect-no-exit-interrupt-checks)
- (with-pc
- (lambda (pc-label pc-register)
- (LAP ,@(clear-map!)
- (LEA (R ,ecx) (@RO W ,pc-register (- ,label ,pc-label)))
- (MOV W (R ,edx) (& ,number-pushed))
- ,@(invoke-interface code:compiler-lexpr-apply)))))
+ (LAP ,@(clear-map!)
+ (LEA Q (R ,rcx) (@PCR ,label))
+ (MOV Q (R ,rdx) (&U ,number-pushed))
+ ,@(invoke-interface code:compiler-lexpr-apply)))
(define-rule statement
(INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
;; It expects the procedure at the top of the stack
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
- (POP (R ,ecx))
- (AND W (R ,ecx) (R ,regnum:datum-mask)) ; clear type code
- (MOV W (R ,edx) (& ,number-pushed))
+ (POP Q (R ,rcx))
+ (AND Q (R ,rcx) (R ,regnum:datum-mask)) ; clear type code
+ (MOV Q (R ,rdx) (&U ,number-pushed))
,@(invoke-interface code:compiler-lexpr-apply)))
(define-rule statement
continuation
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
- (JMP (@PCRO ,(free-uuo-link-label name frame-size) 3))))
+ (JMP (@PCRO ,(free-uuo-link-label name frame-size) 8))))
(define-rule statement
(INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
continuation
(expect-no-exit-interrupt-checks)
(LAP ,@(clear-map!)
- (JMP (@PCRO ,(global-uuo-link-label name frame-size) 3))))
+ (JMP (@PCRO ,(global-uuo-link-label name frame-size) 8))))
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
continuation
(expect-no-exit-interrupt-checks)
(let* ((set-extension
- (interpreter-call-argument->machine-register! extension ecx))
+ (interpreter-call-argument->machine-register! extension rcx))
(set-address
- (begin (require-register! edx)
- (load-pc-relative-address (INST-EA (R ,edx))
+ (begin (require-register! rdx)
+ (load-pc-relative-address (INST-EA (R ,rdx))
*block-label*))))
(delete-dead-registers!)
(LAP ,@set-extension
,@set-address
,@(clear-map!)
- (MOV W (R ,ebx) (& ,frame-size))
+ (MOV Q (R ,rbx) (&U ,frame-size))
,@(invoke-interface code:compiler-cache-reference-apply))))
(define-rule statement
continuation
(expect-no-entry-interrupt-checks)
(let* ((set-environment
- (interpreter-call-argument->machine-register! environment ecx))
- (set-name (object->machine-register! name edx)))
+ (interpreter-call-argument->machine-register! environment rcx))
+ (set-name (object->machine-register! name rdx)))
(delete-dead-registers!)
(LAP ,@set-environment
,@set-name
,@(clear-map!)
- (MOV W (R ,ebx) (& ,frame-size))
+ (MOV Q (R ,rbx) (&U ,frame-size))
,@(invoke-interface code:compiler-lookup-apply))))
\f
(define-rule statement
continuation ; ignored
(if (eq? primitive compiled-error-procedure)
(LAP ,@(clear-map!)
- (MOV W (R ,ecx) (& ,frame-size))
+ (MOV Q (R ,rcx) (&U ,frame-size))
,@(invoke-hook entry:compiler-error))
(let ((arity (primitive-procedure-arity primitive)))
(cond ((not (negative? arity))
- (with-values (lambda () (get-cached-label))
- (lambda (pc-label pc-reg)
- pc-reg ; ignored
- (if pc-label
- (let ((get-code
- (object->machine-register! primitive ecx)))
- (LAP ,@get-code
- ,@(clear-map!)
- ,@(invoke-hook entry:compiler-primitive-apply)))
- (let ((prim-label (constant->label primitive))
- (offset-label (generate-label 'PRIMOFF)))
- (LAP ,@(clear-map!)
- ,@(invoke-hook/call
- entry:compiler-short-primitive-apply)
- (LABEL ,offset-label)
- (LONG S (- ,prim-label ,offset-label))))))))
+ (let ((get-code
+ (object->machine-register! primitive rcx)))
+ (LAP ,@get-code
+ ,@(clear-map!)
+ ,@(invoke-hook entry:compiler-primitive-apply))))
((= arity -1)
- (let ((get-code (object->machine-register! primitive ecx)))
+ (let ((get-code (object->machine-register! primitive rcx)))
(LAP ,@get-code
,@(clear-map!)
- (MOV W ,reg:lexpr-primitive-arity
- (& ,(-1+ frame-size)))
+ (MOV Q ,reg:lexpr-primitive-arity (&U ,(-1+ frame-size)))
,@(invoke-hook entry:compiler-primitive-lexpr-apply))))
(else
;; Unknown primitive arity. Go through apply.
- (let ((get-code (object->machine-register! primitive ecx)))
+ (let ((get-code (object->machine-register! primitive rcx)))
(LAP ,@get-code
,@(clear-map!)
- (MOV W (R ,edx) (& ,frame-size))
+ (MOV Q (R ,rdx) (&U ,frame-size))
,@(invoke-interface code:compiler-apply))))))))
\f
(let-syntax
\f
;;; Invocation Prefixes
+;;; rsp = 4, regnum:stack-pointer
+
(define-rule statement
(INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 4))
(LAP))
(cond ((zero? how-far)
(LAP))
((zero? frame-size)
- (LAP (ADD W (R 4) (& ,(* 4 how-far)))))
+ (LAP (ADD Q (R ,rsp) (&U ,(* address-units-per-object how-far)))))
((= frame-size 1)
(let ((temp (temporary-register-reference)))
- (LAP (MOV W ,temp (@R 4))
- (ADD W (R 4) (& ,(* 4 offset)))
- (PUSH W ,temp))))
+ (LAP (MOV Q ,temp (@R ,rsp))
+ (ADD Q (R ,rsp) (&U ,(* address-units-per-object offset)))
+ (PUSH Q ,temp))))
((= frame-size 2)
(let ((temp1 (temporary-register-reference))
(temp2 (temporary-register-reference)))
- (LAP (MOV W ,temp2 (@RO B 4 4))
- (MOV W ,temp1 (@R 4))
- (ADD W (R 4) (& ,(* 4 offset)))
- (PUSH W ,temp2)
- (PUSH W ,temp1))))
+ (LAP (MOV Q ,temp2 (@RO B ,rsp ,address-units-per-object))
+ (MOV Q ,temp1 (@R ,rsp))
+ (ADD Q (R ,rsp) (&U ,(* address-units-per-object offset)))
+ (PUSH Q ,temp2)
+ (PUSH Q ,temp1))))
(else
(error "INVOCATION-PREFIX:MOVE-FRAME-UP: Incorrectly invoked!")))))
(INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
(REGISTER (? reg-1))
(REGISTER (? reg-2)))
- (QUALIFIER (not (= reg-1 4)))
+ (QUALIFIER (not (= reg-1 rsp)))
(let* ((label (generate-label 'DYN-CHOICE))
(temp1 (move-to-temporary-register! reg-1 'GENERAL))
(temp2 (standard-move-to-temporary! reg-2)))
- (LAP (CMP W (R ,temp1) ,temp2)
+ (LAP (CMP Q (R ,temp1) ,temp2)
(JLE (@PCR ,label))
- (MOV W (R ,temp1) ,temp2)
+ (MOV Q (R ,temp1) ,temp2)
(LABEL ,label)
,@(generate/move-frame-up* frame-size temp1 (lambda () temp2)))))
(define (generate/move-frame-up* frame-size reg get-temp)
(if (zero? frame-size)
- (LAP (MOV W (R 4) (R ,reg)))
+ (LAP (MOV Q (R ,rsp) (R ,reg)))
(let ((temp (get-temp))
(ctr (allocate-temporary-register! 'GENERAL))
(label (generate-label 'MOVE-LOOP)))
- (LAP (LEA (R ,reg)
- ,(byte-offset-reference reg (* -4 frame-size)))
- (MOV W (R ,ctr) (& ,(-1+ frame-size)))
+ (LAP (LEA Q (R ,reg)
+ ,(byte-offset-reference
+ reg
+ (* -1 address-units-per-object frame-size)))
+ (MOV Q (R ,ctr) (&U ,(-1+ frame-size)))
(LABEL ,label)
- (MOV W ,temp (@RI 4 ,ctr 4))
- (MOV W (@RI ,reg ,ctr 4) ,temp)
- (DEC W (R ,ctr))
+ (MOV Q ,temp (@RI ,rsp ,ctr ,address-units-per-object))
+ (MOV Q (@RI ,reg ,ctr ,address-units-per-object) ,temp)
+ (SUB Q (R ,ctr) (&U 1))
(JGE (@PCR ,label))
- (MOV W (R 4) (R ,reg))))))
+ (MOV Q (R ,rsp) (R ,reg))))))
\f
;;;; External Labels
(define (interrupt-check interrupt-label checks)
;; This always does interrupt checks in line.
(LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks))
- (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+ (LAP (CMP Q (R ,regnum:free-pointer) ,reg:compiled-memtop)
(JGE (@PCR ,interrupt-label)))
(LAP))
,@(if (memq 'STACK checks)
- (LAP (CMP W (R ,regnum:stack-pointer) ,reg:stack-guard)
+ (LAP (CMP Q (R ,regnum:stack-pointer) ,reg:stack-guard)
(JL (@PCR ,interrupt-label)))
(LAP))))
internal-label
entry:compiler-interrupt-procedure)))
\f
-;; Interrupt check placement
-;;
-;; The first two procedures are the interface.
-;; GET-EXIT-INTERRUPT-CHECKS and GET-ENTRY-INTERRUPT-CHECKS get a list
-;; of kinds interrupt check. An empty list implies no check is
-;; required. The list can contain these symbols:
-;;
-;; STACK stack check required here
-;; HEAP heap check required here
-;; INTERRUPT check required here to avoid loops without checks.
-;;
-;; The traversal and decision making is done immediately prior to LAP
-;; generation (from PRE-LAPGEN-ANALYSIS.)
-
-(define (get-entry-interrupt-checks)
- (get-interupt-checks 'ENTRY-INTERRUPT-CHECKS))
-
-(define (get-exit-interrupt-checks)
- (get-interupt-checks 'EXIT-INTERRUPT-CHECKS))
-
-(define (expect-no-entry-interrupt-checks)
- (if (not (null? (get-entry-interrupt-checks)))
- (error "No entry interrupt checks expected here" *current-bblock*)))
-
-(define (expect-no-exit-interrupt-checks)
- (if (not (null? (get-exit-interrupt-checks)))
- (error "No exit interrupt checks expected here" *current-bblock*)))
-
-(define (get-interupt-checks kind)
- (cond ((cfg-node-get *current-bblock* kind)
- => cdr)
- (else (error "DETERMINE-INTERRUPT-CHECKS failed" kind))))
-
-;; This algorithm finds leaf-procedure-like paths in the rtl control
-;; flow graph. If a procedure entry point can only reach a return, it
-;; is leaf-like. If a return can only be reached from a procedure
-;; entry, it too is leaf-like.
-;;
-;; If a procedure reaches a procedure call, that could be a loop, so
-;; it is not leaf-like. Similarly, if a continuation entry reaches
-;; return, that could be a long unwinding of recursion, so a check is
-;; needed in case the unwinding does allocation.
-;;
-;; Typically, true leaf procedures avoid both checks, and trivial
-;; cases (like MAP returning '()) avoid the exit check.
-;;
-;; This could be a lot smarter. For example, a procedure entry does
-;; not need to check for interrupts if it reaches call sites of
-;; strictly lesser arity; or it could analyze the cycles in the CFG
-;; and select good places to break them
-;;
-;; The algorithm has three phases: (1) explore the CFG to find all
-;; entry and exit points, (2) propagate entry (exit) information so
-;; that each potential interrupt check point knows what kinds of exits
-;; (entrys) it reaches (is reached from), and (3) decide on the kinds
-;; of interrupt check that are required at each entry and exit.
-;;
-;; [TOFU is just a header node for the list of interrupt checks, to
-;; distingish () and #F]
-
-(define (determine-interrupt-checks bblock)
- (let ((entries '())
- (exits '()))
-
- (define (explore bblock)
- (or (cfg-node-get bblock 'INTERRUPT-CHECK-EXPLORE)
- (begin
- (cfg-node-put! bblock 'INTERRUPT-CHECK-EXPLORE #T)
- (if (node-previous=0? bblock)
- (set! entries (cons bblock entries))
- (if (rtl:continuation-entry?
- (rinst-rtl (bblock-instructions bblock)))
- ;; previous block is invocation:special-primitive
- ;; so it is just an out of line instruction
- (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS '(TOFU))))
-
- (for-each-previous-node bblock explore)
- (for-each-subsequent-node bblock explore)
- (if (and (snode? bblock)
- (or (not (snode-next bblock))
- (let ((last (last-insn bblock)))
- (or (rtl:invocation:special-primitive? last)
- (rtl:invocation:primitive? last)))))
- (set! exits (cons bblock exits))))))
-
- (define (for-each-subsequent-node node procedure)
- (if (snode? node)
- (if (snode-next node)
- (procedure (snode-next node)))
- (begin
- (procedure (pnode-consequent node))
- (procedure (pnode-alternative node)))))
-
- (define (propagator for-each-link)
- (lambda (node update place)
- (let propagate ((node node))
- (let ((old (cfg-node-get node place)))
- (let ((new (update old)))
- (if (not (equal? old new))
- (begin
- (cfg-node-put! node place new)
- (for-each-link node propagate))))))))
-
- (define upward (propagator for-each-previous-node))
- (define downward (propagator for-each-subsequent-node))
-
- (define (setting-flag old) old #T)
-
- (define (propagate-entry-info bblock)
- (let ((insn (rinst-rtl (bblock-instructions bblock))))
- (cond ((or (rtl:continuation-entry? insn)
- (rtl:continuation-header? insn))
- (downward bblock setting-flag 'REACHED-FROM-CONTINUATION))
- ((or (rtl:closure-header? insn)
- (rtl:ic-procedure-header? insn)
- (rtl:open-procedure-header? insn)
- (rtl:procedure-header? insn))
- (downward bblock setting-flag 'REACHED-FROM-PROCEDURE))
- (else unspecific))))
-
- (define (propagate-exit-info exit-bblock)
- (let ((insn (last-insn exit-bblock)))
- (cond ((rtl:pop-return? insn)
- (upward exit-bblock setting-flag 'REACHES-POP-RETURN))
- (else
- (upward exit-bblock setting-flag 'REACHES-INVOCATION)))))
-
- (define (decide-entry-checks bblock)
- (define (checks! types)
- (cfg-node-put! bblock 'ENTRY-INTERRUPT-CHECKS (cons 'TOFU types)))
- (define (decide-label internal-label)
- (let ((object (label->object internal-label)))
- (let ((stack?
- (if (and (rtl-procedure? object)
- (not (rtl-procedure/stack-leaf? object))
- compiler:generate-stack-checks?)
- '(STACK)
- '())))
- (if (or (cfg-node-get bblock 'REACHES-INVOCATION)
- (pair? stack?))
- (checks! (cons* 'HEAP 'INTERRUPT stack?))
- (checks! '())))))
-
- (let ((insn (rinst-rtl (bblock-instructions bblock))))
- (cond ((rtl:continuation-entry? insn) (checks! '()))
- ((rtl:continuation-header? insn) (checks! '()))
- ((rtl:closure-header? insn)
- (decide-label (rtl:closure-header-procedure insn)))
- ((rtl:ic-procedure-header? insn)
- (decide-label (rtl:ic-procedure-header-procedure insn)))
- ((rtl:open-procedure-header? insn)
- (decide-label (rtl:open-procedure-header-procedure insn)))
- ((rtl:procedure-header? insn)
- (decide-label (rtl:procedure-header-procedure insn)))
- (else
- (checks! '(INTERRUPT))))))
-
- (define (last-insn bblock)
- (rinst-rtl (rinst-last (bblock-instructions bblock))))
-
- (define (decide-exit-checks bblock)
- (define (checks! types)
- (cfg-node-put! bblock 'EXIT-INTERRUPT-CHECKS (cons 'TOFU types)))
- (if (rtl:pop-return? (last-insn bblock))
- (if (cfg-node-get bblock 'REACHED-FROM-CONTINUATION)
- (checks! '(INTERRUPT))
- (checks! '()))
- (checks! '())))
-
- (explore bblock)
-
- (for-each propagate-entry-info entries)
- (for-each propagate-exit-info exits)
- (for-each decide-entry-checks entries)
- (for-each decide-exit-checks exits)
-
- ))
-\f
;;;; Closures:
-;; Since i386 instructions are pc-relative, the GC can't relocate them unless
-;; there is a way to find where the closure was in old space before being
-;; transported. The first entry point (tagged as an object) is always
-;; the last component of closures with any entry points.
-
(define (generate/cons-closure target procedure-label min max size)
(let* ((mtarget (target-register target))
(target (register-reference mtarget))
- (temp (temporary-register-reference)))
- (LAP ,@(load-pc-relative-address
- temp
- `(- ,(rtl-procedure/external-label (label->object procedure-label))
- 5))
- (MOV W (@R ,regnum:free-pointer)
- (&U ,(make-non-pointer-literal (ucode-type manifest-closure)
- (+ 4 size))))
- (MOV W (@RO B ,regnum:free-pointer 4)
- (&U ,(make-closure-code-longword min max 8)))
- (LEA ,target (@RO B ,regnum:free-pointer 8))
- ;; (CALL (@PCR <entry>))
- (MOV B (@RO B ,regnum:free-pointer 8) (&U #xe8))
- (SUB W ,temp ,target)
- (MOV W (@RO B ,regnum:free-pointer 9) ,temp) ; displacement
- (ADD W (R ,regnum:free-pointer) (& ,(* 4 (+ 5 size))))
- (LEA ,temp (@RO UW
- ,mtarget
- ,(make-non-pointer-literal (ucode-type compiled-entry)
- 0)))
- (MOV W (@RO B ,regnum:free-pointer -4) ,temp)
- ,@(invoke-hook/call entry:compiler-conditionally-serialize))))
+ (temp (temporary-register-reference))
+ (data-offset address-units-per-closure-manifest)
+ (format-offset (+ data-offset address-units-per-closure-entry-count))
+ (pc-offset (+ format-offset address-units-per-entry-format-code))
+ (slots-offset
+ (+ pc-offset
+ address-units-per-closure-entry-instructions
+ address-units-per-closure-padding))
+ (free-offset
+ (+ slots-offset (* size address-units-per-object))))
+ (LAP (MOV Q ,temp (&U ,(make-closure-manifest size)))
+ (MOV Q (@R ,regnum:free-pointer) ,temp)
+ ;; There's only one entry point here.
+ (MOV L (@RO B ,regnum:free-pointer ,data-offset) (&U 1))
+ ,@(generate-closure-entry procedure-label min max format-offset temp)
+ ;; Load the address of the entry instruction into TARGET.
+ (LEA Q ,target (@RO B ,regnum:free-pointer ,pc-offset))
+ ;; Bump FREE.
+ (ADD Q (R ,regnum:free-pointer) (&U ,free-offset)))))
(define (generate/cons-multiclosure target nentries size entries)
(let* ((mtarget (target-register target))
(target (register-reference mtarget))
(temp (temporary-register-reference)))
- (with-pc
- (lambda (pc-label pc-reg)
- (define (generate-entries entries offset)
- (let ((entry (car entries))
- (rest (cdr entries)))
- (LAP (MOV W (@RO B ,regnum:free-pointer -9)
- (&U ,(make-closure-code-longword (cadr entry)
- (caddr entry)
- offset)))
- (MOV B (@RO B ,regnum:free-pointer -5) (&U #xe8))
- (LEA ,temp (@RO W
- ,pc-reg
- (- ,(rtl-procedure/external-label
- (label->object (car entry)))
- ,pc-label)))
- (SUB W ,temp (R ,regnum:free-pointer))
- (MOV W (@RO B ,regnum:free-pointer -4) ,temp)
- ,@(if (null? rest)
- (LAP)
- (LAP (ADD W (R ,regnum:free-pointer) (& 10))
- ,@(generate-entries rest (+ 10 offset)))))))
-
- (LAP (MOV W (@R ,regnum:free-pointer)
- (&U ,(make-non-pointer-literal
- (ucode-type manifest-closure)
- (+ size (quotient (* 5 (1+ nentries)) 2)))))
- (MOV W (@RO B ,regnum:free-pointer 4)
- (&U ,(make-closure-longword nentries 0)))
- (LEA ,target (@RO B ,regnum:free-pointer 12))
- (ADD W (R ,regnum:free-pointer) (& 17))
- ,@(generate-entries entries 12)
- (ADD W (R ,regnum:free-pointer)
- (& ,(+ (* 4 size) (if (odd? nentries) 7 5))))
- (LEA ,temp
- (@RO UW
- ,mtarget
- ,(make-non-pointer-literal (ucode-type compiled-entry)
- 0)))
- (MOV W (@RO B ,regnum:free-pointer -4) ,temp)
- ,@(invoke-hook/call entry:compiler-conditionally-serialize))))))
+ (define (generate-entries entries offset)
+ (LAP ,@(let ((entry (car entries)))
+ (let ((label (car entry))
+ (min (cadr entry))
+ (max (caddr entry)))
+ (generate-closure-entry label min max offset temp)))
+ ,@(generate-entries (cdr entries)
+ (+ offset address-units-per-closure-entry))))
+ (let* ((data-offset address-units-per-closure-manifest)
+ (first-format-offset
+ (+ data-offset address-units-per-closure-entry-count))
+ (first-pc-offset
+ (+ first-format-offset address-units-per-entry-format-code)))
+ (LAP (MOV Q ,temp (&U ,(make-multiclosure-manifest nentries size)))
+ (MOV Q (@R ,regnum:free-pointer) ,temp)
+ (MOV L (@RO ,regnum:free-pointer ,data-offset) (&U ,nentries))
+ ,@(generate-entries entries first-format-offset)
+ (LEA Q ,target (@RO B ,regnum:free-pointer ,first-pc-offset))
+ (ADD Q (R ,regnum:free-pointer)
+ ,(+ first-format-offset
+ (* nentries address-units-per-closure-entry)
+ (* size address-units-per-object)))))))
+
+(define (generate-closure-entry label min max offset temp)
+ (let* ((procedure-label (rtl-procedure/external-label (label->object label)))
+ (MOV-offset (+ offset address-units-per-entry-format-code))
+ (imm64-offset (+ MOV-offset 2))
+ (CALL-offset (+ imm64-offset 8)))
+ (LAP (MOV L (@RO B ,regnum:free-pointer ,offset)
+ (&U ,(make-closure-code-longword min max MOV-offset)))
+ (LEA Q ,temp (@PCR ,procedure-label))
+ ;; (MOV Q (R ,rax) (&U <procedure-label>))
+ ;; The instruction sequence is really `48 b8', but this is a
+ ;; stupid little-endian architecture. I want my afternoon
+ ;; back.
+ (MOV W (@RO B ,regnum:free-pointer ,MOV-offset) (&U #xB848))
+ (MOV Q (@RO B ,regnum:free-pointer ,imm64-offset) ,temp)
+ ;; (CALL (R ,rax))
+ (MOV W (@RO B ,regnum:free-pointer ,CALL-offset) (&U #xD0FF)))))
\f
-(define closure-share-names
- '#(closure-0-interrupt closure-1-interrupt closure-2-interrupt
- closure-3-interrupt closure-4-interrupt closure-5-interrupt
- closure-6-interrupt closure-7-interrupt))
-
-(define (generate/closure-header internal-label nentries entry)
- nentries ; ignored
+(define (generate/closure-header internal-label nentries)
(let* ((rtl-proc (label->object internal-label))
(external-label (rtl-procedure/external-label rtl-proc))
(checks (get-entry-interrupt-checks)))
- (if (zero? nentries)
- (LAP (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header
- (internal-procedure-code-word rtl-proc)
- internal-label
- entry:compiler-interrupt-procedure))
- (let* ((prefix
- (lambda (gc-label)
- (LAP (LABEL ,gc-label)
- ,@(if (zero? entry)
- (LAP)
- (LAP (ADD W (@R ,esp) (& ,(* 10 entry)))))
- ,@(invoke-hook entry:compiler-interrupt-closure))))
- (label+adjustment
- (lambda ()
- (LAP ,@(make-external-label internal-entry-code-word
- external-label)
- (ADD W (@R ,esp)
- (&U ,(generate/make-magic-closure-constant entry)))
- (LABEL ,internal-label))))
- (suffix
- (lambda (gc-label)
- (LAP ,@(label+adjustment)
- ,@(interrupt-check gc-label checks)))))
- (if (null? checks)
- (LAP ,@(label+adjustment))
- (if (>= entry (vector-length closure-share-names))
- (let ((gc-label (generate-label)))
- (LAP ,@(prefix gc-label)
- ,@(suffix gc-label)))
- (share-instruction-sequence!
- (vector-ref closure-share-names entry)
- suffix
- (lambda (gc-label)
- (LAP ,@(prefix gc-label)
- ,@(suffix gc-label))))))))))
-
-(define (generate/make-magic-closure-constant entry)
- (- (make-non-pointer-literal (ucode-type compiled-entry) 0)
- (+ (* entry 10) 5)))
-
-(define (make-closure-longword code-word pc-offset)
+ (define (label+adjustment)
+ (LAP ,@(make-external-label internal-entry-code-word external-label)
+ ;; Assumption: RAX is not in use here. (In fact, it is
+ ;; used to store the absolute address of this header.)
+ ;; See comment by CLOSURE-ENTRY-MAGIC to understand
+ ;; what's going on here.
+ (MOV Q (R ,rax) (&U ,(closure-entry-magic)))
+ (ADD Q (@R ,rsp) (R ,rax))
+ (LABEL ,internal-label)))
+ (cond ((zero? nentries)
+ (LAP (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header
+ (internal-procedure-code-word rtl-proc)
+ internal-label
+ entry:compiler-interrupt-procedure)))
+ ((pair? checks)
+ (let ((gc-label (generate-label 'GC-LABEL)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-hook entry:compiler-interrupt-closure)
+ ,@(label+adjustment)
+ ,@(interrupt-check gc-label checks))))
+ (else
+ (label+adjustment)))))
+
+;;; On entry to a closure, the quadword at the top of the stack will
+;;; be an untagged pointer to the byte following the CALL instruction
+;;; that led the machine there. CLOSURE-ENTRY-MAGIC returns a number
+;;; that, when added to this quadword, yields the tagged compiled
+;;; entry that was used to invoke the closure. This is what the RTL
+;;; deals with, and this is what interrupt handlers want, particularly
+;;; for the garbage collector, which wants to find only nice tagged
+;;; pointers on the stack.
+
+(define-integrable (closure-entry-magic)
+ (- (make-non-pointer-literal (ucode-type COMPILED-ENTRY) 0)
+ address-units-per-closure-entry-instructions))
+
+(define-integrable (make-closure-manifest size)
+ (make-multiclosure-manifest 1 size))
+
+(define-integrable (make-multiclosure-manifest nentries size)
+ (make-non-pointer-literal
+ (ucode-type MANIFEST-CLOSURE)
+ (+ (quotient (+ address-units-per-closure-entry-count
+ (* nentries address-units-per-closure-entry)
+ address-units-per-closure-padding
+ 7)
+ 8)
+ size)))
+
+(define-integrable (make-closure-longword code-word pc-offset)
(+ code-word (* #x20000 pc-offset)))
-(define (make-closure-code-longword frame/min frame/max pc-offset)
+(define-integrable (make-closure-code-longword frame/min frame/max pc-offset)
(make-closure-longword (make-procedure-code-word frame/min frame/max)
pc-offset))
\f
(define-rule statement
(CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
- (generate/closure-header internal-label nentries entry))
+ entry ;ignore
+ (generate/closure-header internal-label nentries))
(define-rule statement
(ASSIGN (REGISTER (? target))
(case nentries
((0)
(let ((target (target-register-reference target)))
- (LAP (MOV W ,target (R ,regnum:free-pointer))
- (MOV W (@R ,regnum:free-pointer)
+ (LAP (MOV Q ,target ;Use TARGET as a temporary.
(&U ,(make-non-pointer-literal (ucode-type manifest-vector)
size)))
- (ADD W (R ,regnum:free-pointer) (& ,(* 4 (1+ size)))))))
+ (MOV Q (@R ,regnum:free-pointer) ,target)
+ (MOV Q ,target (R ,regnum:free-pointer))
+ (ADD Q (R ,regnum:free-pointer)
+ (& ,(* address-units-per-object (1+ size)))))))
((1)
(let ((entry (vector-ref entries 0)))
(generate/cons-closure target
;;; This is invoked by the top level of the LAP generator.
(define (generate/quotation-header environment-label free-ref-label n-sections)
- (pc->reg eax
- (lambda (pc-label prefix)
- (LAP ,@prefix
- (MOV W (R ,ecx) ,reg:environment)
- (MOV W (@RO W ,eax (- ,environment-label ,pc-label))
- (R ,ecx))
- (LEA (R ,edx) (@RO W ,eax (- ,*block-label* ,pc-label)))
- (LEA (R ,ebx) (@RO W ,eax (- ,free-ref-label ,pc-label)))
- (MOV W ,reg:utility-arg-4 (& ,n-sections))
- #|
- ,@(invoke-interface/call code:compiler-link)
- |#
- ,@(invoke-hook/call entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))
+ (LAP (MOV Q (R ,rcx) ,reg:environment)
+ (MOV Q (@PCR ,environment-label) (R ,rcx))
+ (LEA Q (R ,rdx) (@PCR ,*block-label*))
+ (LEA Q (R ,rbx) (@PCR ,free-ref-label))
+ (MOV Q ,reg:utility-arg-4 (&U ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word #f)
+ (generate-label))))
(define (generate/remote-link code-block-label
environment-offset
free-ref-offset
n-sections)
- (pc->reg eax
- (lambda (pc-label prefix)
- (LAP ,@prefix
- (MOV W (R ,edx) (@RO W ,eax (- ,code-block-label ,pc-label)))
- (AND W (R ,edx) (R ,regnum:datum-mask))
- (LEA (R ,ebx) (@RO W ,edx ,free-ref-offset))
- (MOV W (R ,ecx) ,reg:environment)
- (MOV W (@RO W ,edx ,environment-offset) (R ,ecx))
- (MOV W ,reg:utility-arg-4 (& ,n-sections))
- #|
- ,@(invoke-interface/call code:compiler-link)
- |#
- ,@(invoke-hook/call entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))))))
+ (LAP (MOV Q (R ,rdx) (@PCR ,code-block-label))
+ (AND Q (R ,rdx) (R ,regnum:datum-mask))
+ (LEA Q (R ,rbx) (@RO L ,rdx ,free-ref-offset))
+ (MOV Q (R ,rcx) ,reg:environment)
+ (MOV Q (@RO L ,rdx ,environment-offset) (R ,rcx))
+ (MOV Q ,reg:utility-arg-4 (&U ,n-sections))
+ #|
+ ,@(invoke-interface/call code:compiler-link)
+ |#
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word #f)
+ (generate-label))))
\f
(define (generate/remote-links n-blocks vector-label nsects)
(if (zero? n-blocks)
(LAP)
(let ((loop (generate-label))
- (bytes (generate-label))
+ (bytes (generate-label))
(end (generate-label)))
(LAP
;; Push counter
- (PUSH W (& 0))
- (LABEL ,loop)
- ,@(pc->reg
- eax
- (lambda (pc-label prefix)
- (LAP ,@prefix
- ;; Get index
- (MOV W (R ,ecx) (@R ,esp))
- ;; Get vector
- (MOV W (R ,edx) (@RO W ,eax (- ,vector-label ,pc-label)))
- ;; Get n-sections for this cc-block
- (XOR W (R ,ebx) (R ,ebx))
- (MOV B (R ,ebx) (@ROI B ,eax (- ,bytes ,pc-label) ,ecx 1))
- ;; address of vector
- (AND W (R ,edx) (R ,regnum:datum-mask))
- ;; Store n-sections in arg
- (MOV W ,reg:utility-arg-4 (R ,ebx))
- ;; vector-ref -> cc block
- (MOV W (R ,edx) (@ROI B ,edx 4 ,ecx 4))
- ;; address of cc-block
- (AND W (R ,edx) (R ,regnum:datum-mask))
- ;; cc-block length
- (MOV W (R ,ebx) (@R ,edx))
- ;; Get environment
- (MOV W (R ,ecx) ,reg:environment)
- ;; Eliminate length tags
- (AND W (R ,ebx) (R ,regnum:datum-mask))
- ;; Store environment
- (MOV W (@RI ,edx ,ebx 4) (R ,ecx))
- ;; Get NMV header
- (MOV W (R ,ecx) (@RO B ,edx 4))
- ;; Eliminate NMV tag
- (AND W (R ,ecx) (R ,regnum:datum-mask))
- ;; Address of first free reference
- (LEA (R ,ebx) (@ROI B ,edx 8 ,ecx 4))
- ;; Invoke linker
- ,@(invoke-hook/call entry:compiler-link)
- ,@(make-external-label (continuation-code-word false)
- (generate-label))
- ;; Increment counter and loop
- (INC W (@R ,esp))
- (CMP W (@R ,esp) (& ,n-blocks))
- (JL (@PCR ,loop))
- )))
+ (PUSH Q (& 0))
+ (LABEL ,loop)
+ ;; Get index
+ (MOV Q (R ,rcx) (@R ,rsp))
+ ;; Get vector
+ (MOV Q (R ,rdx) (@PCR ,vector-label))
+ ;; Get n-sections for this cc-block
+ (XOR Q (R ,rbx) (R ,rbx))
+ (LEA Q (R ,rax) (@PCR ,bytes))
+ (MOV B (R ,rbx) (@RI ,rax ,rcx 1))
+ ;; address of vector
+ (AND Q (R ,rdx) (R ,regnum:datum-mask))
+ ;; Store n-sections in arg
+ (MOV Q ,reg:utility-arg-4 (R ,rbx))
+ ;; vector-ref -> cc block
+ (MOV Q
+ (R ,rdx)
+ (@ROI B
+ ,rdx ,address-units-per-object
+ ,rcx ,address-units-per-object))
+ ;; address of cc-block
+ (AND Q (R ,rdx) (R ,regnum:datum-mask))
+ ;; cc-block length
+ (MOV Q (R ,rbx) (@R ,rdx))
+ ;; Get environment
+ (MOV Q (R ,rcx) ,reg:environment)
+ ;; Eliminate length tags
+ (AND Q (R ,rbx) (R ,regnum:datum-mask))
+ ;; Store environment
+ (MOV Q (@RI ,rdx ,rbx ,address-units-per-object) (R ,rcx))
+ ;; Get NMV header
+ (MOV Q (R ,rcx) (@RO B ,rdx ,address-units-per-object))
+ ;; Eliminate NMV tag
+ (AND Q (R ,rcx) (R ,regnum:datum-mask))
+ ;; Address of first free reference
+ (LEA Q
+ (R ,rbx)
+ (@ROI B
+ ,rdx ,(* 2 address-units-per-object)
+ ,rcx ,address-units-per-object))
+ ;; Invoke linker
+ ,@(invoke-hook/call entry:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; Increment counter and loop
+ (ADD Q (@R ,rsp) (&U 1))
+ (CMP Q (@R ,rsp) (&U ,n-blocks))
+ (JL (@PCR ,loop))
+
(JMP (@PCR ,end))
- (LABEL ,bytes)
+ (LABEL ,bytes)
,@(let walk ((bytes (vector->list nsects)))
(if (null? bytes)
(LAP)
(LAP (BYTE U ,(car bytes))
,@(walk (cdr bytes)))))
- (LABEL ,end)
+ (LABEL ,end)
;; Pop counter
- (POP (R ,eax))))))
+ (POP Q (R ,rax))))))
\f
(define (generate/constants-block constants references assignments
uuo-links global-links static-vars)
. ,label)
,@constants))))
(cons (car info) (inner constants))))
-\f
+
;; IMPORTANT:
;; frame-size and uuo-label are switched (with respect to the 68k
;; version) in order to preserve the arity in a constant position (the
-;; i386 is little-endian). The invocation rule for uuo-links has been
-;; changed to take the extra 2 bytes into account.
-;;
-;; Like closures, execute caches use pc-relative JMP instructions,
-;; which can only be relocated if the old address is available.
-;; Thus execute-cache blocks are extended by a single word that
-;; contains its own address.
-
-(define (transmogrifly uuos)
- (define (do-rest uuos)
- (define (inner name assoc)
- (if (null? assoc)
- (do-rest (cdr uuos))
- (cons (cons (caar assoc) ; frame-size
- (cdar assoc)) ; uuo-label
- (cons (cons name ; variable name
- (allocate-constant-label)) ; dummy label
- (inner name (cdr assoc))))))
-
- (if (null? uuos)
- '()
- (inner (caar uuos) (cdar uuos))))
-
- (if (null? uuos)
- '()
- (cons (cons false (allocate-constant-label)) ; relocation address
- (do-rest uuos))))
+;; x86 is little-endian). The invocation rule for uuo-links has been
+;; changed to take the extra object into account.
+
+(define (transmogrifly variable.caches-list)
+ (append-map
+ (lambda (variable.caches)
+ (append-map (let ((variable (car variable.caches)))
+ (lambda (cache)
+ (let ((frame-size (car cache))
+ (label (cdr cache)))
+ `((,frame-size . ,label)
+ (,variable . ,(allocate-constant-label))
+ (#F . ,(allocate-constant-label))))))
+ (cdr variable.caches)))
+ variable.caches-list))
\f
;;; Local Variables: ***
;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
(QUALIFIER (interpreter-call-argument? extension))
cont ; ignored
(let ((set-extension
- (interpreter-call-argument->machine-register! extension edx)))
+ (interpreter-call-argument->machine-register! extension rdx)))
(LAP ,@set-extension
,@(clear-map!)
#|
(interpreter-call-argument? value)))
cont ; ignored
(let* ((set-extension
- (interpreter-call-argument->machine-register! extension edx))
- (set-value (interpreter-call-argument->machine-register! value ebx)))
+ (interpreter-call-argument->machine-register! extension rdx))
+ (set-value (interpreter-call-argument->machine-register! value rbx)))
(LAP ,@set-extension
,@set-value
,@(clear-map!)
(QUALIFIER (interpreter-call-argument? extension))
cont ; ignored
(let ((set-extension
- (interpreter-call-argument->machine-register! extension edx)))
+ (interpreter-call-argument->machine-register! extension rdx)))
(LAP ,@set-extension
,@(clear-map!)
,@(invoke-interface/call code:compiler-unassigned?-trap))))
(define (lookup-call code environment name)
(let ((set-environment
- (interpreter-call-argument->machine-register! environment edx)))
+ (interpreter-call-argument->machine-register! environment rdx)))
(LAP ,@set-environment
,@(clear-map (clear-map!))
- ,@(load-constant (INST-EA (R ,ebx)) name)
+ ,@(load-constant->register (INST-EA (R ,rbx)) name)
,@(invoke-interface/call code))))
\f
(define-rule statement
(define (assignment-call code environment name value)
(let* ((set-environment
- (interpreter-call-argument->machine-register! environment edx))
- (set-value (interpreter-call-argument->machine-register! value eax)))
+ (interpreter-call-argument->machine-register! environment rdx))
+ (set-value (interpreter-call-argument->machine-register! value rax)))
(LAP ,@set-environment
,@set-value
,@(clear-map!)
- (MOV W ,reg:utility-arg-4 (R ,eax))
- ,@(load-constant (INST-EA (R ,ebx)) name)
+ (MOV Q ,reg:utility-arg-4 (R ,rax))
+ ,@(load-constant->register (INST-EA (R ,rbx)) name)
,@(invoke-interface/call code))))
\ No newline at end of file
(define-rule rewriting
(CONS-NON-POINTER (? type) (? datum))
- ;; On i386, there's no difference between an address and a datum,
+ ;; On x86, there's no difference between an address and a datum,
;; so the rules for constructing non-pointer objects are the same as
;; those for pointer objects.
(rtl:make-cons-pointer type datum))
projects / mit-scheme.git / commitdiff