From: Taylor R Campbell Date: Fri, 30 Oct 2009 22:11:15 +0000 (-0400) Subject: Adapt general LAP generation rules to AMD x86-64. X-Git-Tag: 20100708-Gtk~288 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bc6da5d282ac28257cc2c4a0c564efdf86f0cf67;p=mit-scheme.git Adapt general LAP generation rules to AMD x86-64. Move interrupt-check analysis to new file back/checks.scm. Later, the other back ends should switch to using this, rather than having copies of the code. Fixnum and flonum rules are not yet adapted. --- diff --git a/src/compiler/back/checks.scm b/src/compiler/back/checks.scm new file mode 100644 index 000000000..98d50ba26 --- /dev/null +++ b/src/compiler/back/checks.scm @@ -0,0 +1,200 @@ +#| -*-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)) + +;; 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. + +(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))))) + + (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 diff --git a/src/compiler/machines/x86-64/lapgen.scm b/src/compiler/machines/x86-64/lapgen.scm index 988684439..98f5c2f45 100644 --- a/src/compiler/machines/x86-64/lapgen.scm +++ b/src/compiler/machines/x86-64/lapgen.scm @@ -31,13 +31,26 @@ USA. ;;;; 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. @@ -57,27 +70,38 @@ USA. (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)))) + (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)) @@ -85,6 +109,7 @@ USA. (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))) @@ -101,7 +126,12 @@ USA. (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))) @@ -134,8 +164,9 @@ USA. (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) @@ -144,8 +175,9 @@ USA. (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)) @@ -153,32 +185,48 @@ USA. (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)) + +;++ 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) @@ -187,6 +235,20 @@ USA. (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)) @@ -195,6 +257,7 @@ USA. (define-integrable (float-register? register) (<= fr0 register fr7)) +|# ;;;; Utilities for the rules @@ -219,7 +282,8 @@ USA. (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)) @@ -227,84 +291,111 @@ USA. (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))))))) - -(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))))) + +;;;; 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))) + +(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))))) (define (target-register target) (delete-dead-registers!) @@ -350,7 +441,7 @@ USA. (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 @@ -385,10 +476,12 @@ USA. (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)))) (define (rtl:simple-offset? expression) (and (rtl:offset? expression) @@ -410,15 +503,16 @@ USA. (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) @@ -478,7 +572,9 @@ USA. (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))) @@ -488,26 +584,27 @@ USA. (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))))) (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)) @@ -527,15 +624,15 @@ USA. (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)))))) @@ -599,13 +696,18 @@ USA. (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))) +;++ 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) @@ -620,15 +722,15 @@ USA. (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. @@ -646,7 +748,7 @@ USA. primitive-error short-primitive-apply) -(define-entries #x-80 0 +(define-entries #x-100 0 &+ &- &* @@ -691,5 +793,5 @@ USA. (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 diff --git a/src/compiler/machines/x86-64/rules1.scm b/src/compiler/machines/x86-64/rules1.scm index 9387275be..cbd5902fb 100644 --- a/src/compiler/machines/x86-64/rules1.scm +++ b/src/compiler/machines/x86-64/rules1.scm @@ -45,13 +45,13 @@ USA. (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)) @@ -69,13 +69,13 @@ USA. (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. @@ -83,7 +83,10 @@ USA. (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)) @@ -100,8 +103,25 @@ USA. (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)) @@ -111,10 +131,10 @@ USA. (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) @@ -125,6 +145,7 @@ USA. (two-arg (get-tgt)))) (else (three-arg alias))))))) +|# (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source)))) @@ -137,18 +158,18 @@ USA. ;;;; 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))) @@ -201,11 +222,11 @@ USA. (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 @@ -213,22 +234,18 @@ USA. (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?) @@ -236,33 +253,44 @@ USA. (MACHINE-CONSTANT (? n)))) (if (zero? n) (LAP) - (LAP (ADD W ,(offset->reference! expression) (& ,n))))) + (LAP (ADD Q ,(offset->reference! expression) (& ,n))))) ;;;; 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))))) ;;;; CHAR->ASCII/BYTE-OFFSET @@ -325,18 +353,37 @@ USA. (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)) @@ -349,19 +396,37 @@ USA. (+ (make-non-pointer-literal type 0) n)) false)) - + (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))) @@ -369,7 +434,7 @@ USA. ;; 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) @@ -383,7 +448,7 @@ USA. (? 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?) @@ -391,12 +456,15 @@ USA. (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) diff --git a/src/compiler/machines/x86-64/rules2.scm b/src/compiler/machines/x86-64/rules2.scm index 73585baac..97c0c4ac3 100644 --- a/src/compiler/machines/x86-64/rules2.scm +++ b/src/compiler/machines/x86-64/rules2.scm @@ -47,42 +47,38 @@ USA. (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)) (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))) @@ -103,32 +99,32 @@ USA. (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 @@ -139,5 +135,5 @@ USA. (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))))))) diff --git a/src/compiler/machines/x86-64/rules3.scm b/src/compiler/machines/x86-64/rules3.scm index a14f7f281..16424b910 100644 --- a/src/compiler/machines/x86-64/rules3.scm +++ b/src/compiler/machines/x86-64/rules3.scm @@ -36,23 +36,22 @@ USA. ;; 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)))))) @@ -65,9 +64,9 @@ USA. 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 @@ -80,7 +79,7 @@ USA. ((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 @@ -96,20 +95,18 @@ USA. ;; 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)))) (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)) @@ -117,9 +114,9 @@ USA. ;; 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 @@ -127,14 +124,14 @@ USA. 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)) @@ -142,16 +139,16 @@ USA. 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 @@ -160,13 +157,13 @@ USA. 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)))) (define-rule statement @@ -174,39 +171,27 @@ USA. 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)))))))) (let-syntax @@ -255,6 +240,8 @@ USA. ;;; Invocation Prefixes +;;; rsp = 4, regnum:stack-pointer + (define-rule statement (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 4)) (LAP)) @@ -274,20 +261,20 @@ USA. (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!"))))) @@ -301,31 +288,33 @@ USA. (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)))))) ;;;; External Labels @@ -389,11 +378,11 @@ USA. (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)))) @@ -456,323 +445,140 @@ USA. internal-label entry:compiler-interrupt-procedure))) -;; 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) - - )) - ;;;; 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 )) - (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 )) + ;; 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))))) -(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)) (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)) @@ -786,11 +592,13 @@ USA. (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 @@ -804,104 +612,102 @@ USA. ;;; 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)))) (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)))))) (define (generate/constants-block constants references assignments uuo-links global-links static-vars) @@ -954,37 +760,25 @@ USA. . ,label) ,@constants)))) (cons (car info) (inner constants)))) - + ;; 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)) ;;; Local Variables: *** ;;; eval: (put 'declare-constants 'scheme-indent-hook 2) *** diff --git a/src/compiler/machines/x86-64/rules4.scm b/src/compiler/machines/x86-64/rules4.scm index 776b3ae61..735c1daca 100644 --- a/src/compiler/machines/x86-64/rules4.scm +++ b/src/compiler/machines/x86-64/rules4.scm @@ -35,7 +35,7 @@ USA. (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!) #| @@ -54,8 +54,8 @@ USA. (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!) @@ -69,7 +69,7 @@ USA. (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)))) @@ -107,10 +107,10 @@ USA. (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)))) (define-rule statement @@ -129,11 +129,11 @@ USA. (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 diff --git a/src/compiler/machines/x86-64/rulrew.scm b/src/compiler/machines/x86-64/rulrew.scm index c85f9f930..70259dc8e 100644 --- a/src/compiler/machines/x86-64/rulrew.scm +++ b/src/compiler/machines/x86-64/rulrew.scm @@ -32,7 +32,7 @@ USA. (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))