From c17bd546197abd785d00fd9c10f3f09b9b9b0abe Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 5 Mar 2007 01:55:22 +0000 Subject: [PATCH] Add support for dynamic-extent for ppc. Simple tests with rest args and some dynamic-extent closures indicates that this work. Compiling CMUCL with dynamic-extent enabled appears to work as well. I conclude that the implementation here is probably correct. (Yes, I know dynamic-extent is currently disabled, but let's make ppc complete.) compiler/ppc/alloc.lisp: o Implement the vops %DYNAMIC-EXTENT-START and %DYNAMIC-EXTENT-END. o Update the LIST-OR-LIST*, MAKE-CLOSURE, and FIXED-ALLOC vops to support dynamic-extent, by passing ALLOCATION and WITH-FIXED-ALLOCATION macros the extra :STACK-P arg. compiler/ppc/call.lisp: o Update LISTIFY-REST-ARGS vop to support dynamic-extent, by passing the ALLOCATION macro the extra :STACK-P arg. compiler/ppc/macros.lisp: o Update the ALLOCATION macro to support the :STACK-P arg. --- compiler/ppc/alloc.lisp | 38 +++++++++++++----- compiler/ppc/call.lisp | 5 ++- compiler/ppc/macros.lisp | 86 ++++++++++++++++++++++++++++++++++++++-- 3 files changed, 115 insertions(+), 14 deletions(-) diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp index 64b2b9a23..60e5f686e 100644 --- a/compiler/ppc/alloc.lisp +++ b/compiler/ppc/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.14 2006/01/18 15:21:26 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.15 2007/03/05 01:55:21 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -21,17 +21,35 @@ ;;;; Dynamic-Extent (not implemented). +;;; +;;; Take an arg where to move the stack pointer instead of returning +;;; it via :results, because the former generates a single move. +;;; (define-vop (%dynamic-extent-start) - (:args (saved-stack-pointer :scs (any-reg))) + (:args (saved-stack-pointer :scs (any-reg control-stack))) (:results) (:policy :safe) - (:generator 0)) + (:generator 0 + (sc-case saved-stack-pointer + (control-stack + (let ((offset (tn-offset saved-stack-pointer))) + (storew csp-tn cfp-tn offset))) + (any-reg + (move saved-stack-pointer csp-tn))))) + (define-vop (%dynamic-extent-end) - (:args (saved-stack-pointer :scs (any-reg))) + (:args (saved-stack-pointer :scs (any-reg control-stack))) (:results) (:policy :safe) - (:generator 0)) + (:generator 0 + (sc-case saved-stack-pointer + (control-stack + (let ((offset (tn-offset saved-stack-pointer))) + (loadw csp-tn cfp-tn offset))) + (any-reg + (move csp-tn saved-stack-pointer))))) + ;;;; LIST and LIST* @@ -67,7 +85,8 @@ (alloc (* (pad-data-block cons-size) cons-cells))) (pseudo-atomic (pa-flag) (allocation res alloc list-pointer-type :temp-tn alloc-temp - :flag-tn pa-flag) + :flag-tn pa-flag + :stack-p dynamic-extent) (move ptr res) (dotimes (i (1- cons-cells)) (storew (maybe-load (tn-ref-tn things)) ptr @@ -151,13 +170,13 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:results (result :scs (descriptor-reg))) - (:ignore dynamic-extent) (:generator 10 (let ((size (+ length closure-info-offset))) (pseudo-atomic (pa-flag) (allocation result (pad-data-block size) function-pointer-type - :temp-tn temp :flag-tn pa-flag) + :temp-tn temp :flag-tn pa-flag + :stack-p dynamic-extent) (inst lr temp (logior (ash (1- size) type-bits) closure-header-type)) (storew temp result 0 function-pointer-type))) (storew function result closure-function-slot function-pointer-type))) @@ -192,7 +211,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag) (:generator 4 - (with-fixed-allocation (result pa-flag temp type words :lowtag lowtag) + (with-fixed-allocation (result pa-flag temp type words :lowtag lowtag + :stack-p dynamic-extent) ))) (define-vop (var-alloc) diff --git a/compiler/ppc/call.lisp b/compiler/ppc/call.lisp index fdbc0047e..bd07939aa 100644 --- a/compiler/ppc/call.lisp +++ b/compiler/ppc/call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.15 2007/03/03 01:52:07 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/call.lisp,v 1.16 2007/03/05 01:55:22 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -1212,7 +1212,8 @@ default-value-8 (assemble () ;; Allocate a cons (2 words) for each item. (inst slwi temp count 1) - (allocation result temp list-pointer-type :temp-tn dst :flag-tn pa-flag) + (allocation result temp list-pointer-type :temp-tn dst :flag-tn pa-flag + :stack-p dynamic-extent) (move dst result) (inst b enter) diff --git a/compiler/ppc/macros.lisp b/compiler/ppc/macros.lisp index 342ff45c3..d774bda2f 100644 --- a/compiler/ppc/macros.lisp +++ b/compiler/ppc/macros.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.12 2006/02/08 01:32:58 rtoy Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.13 2007/03/05 01:55:22 rtoy Rel $ ;;; ;;; This file contains various useful macros for generating PC code. ;;; @@ -153,6 +153,7 @@ ;; applied. The amount of space to be allocated is SIZE bytes (which ;; must be a multiple of the lisp object size). ;; +#+nil (defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn) (declare (ignore stack-p) #-gencgc @@ -203,9 +204,87 @@ (inst sub ,result-tn ,result-tn ,temp-tn) ;; Set the lowtag appropriately (inst ori ,result-tn ,result-tn ,lowtag)))) + +(defmacro allocation (result-tn size lowtag &key stack-p temp-tn flag-tn) + (declare #-gencgc + (ignore temp-tn flag-tn)) + (let ((alloc-size (gensym))) + `(cond (,stack-p + ;; Stack allocation + ;; + ;; The control stack grows up, so round up CSP to a + ;; multiple of 8 (lispobj size). Use that as the + ;; allocation pointer. Then add SIZE bytes to the + ;; allocation and set CSP to that, so we have the desired + ;; space. + + ;; Make sure the temp-tn is a non-descriptor register! + (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg))) + + ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size) + (inst li ,flag-tn vm:lowtag-mask) + (inst addi ,temp-tn csp-tn vm:lowtag-mask) + (inst andc ,temp-tn ,temp-tn ,flag-tn) + ;; Set the result to temp-tn, with appropriate lowtag + (inst ori ,result-tn ,temp-tn ,lowtag) + + ;; Allocate the desired space on the stack. + ;; + ;; FIXME: Can't allocate on stack if SIZE is too large. + ;; Need to rearrange this code. + (if (tn-p ,size) + (inst add csp-tn ,temp-tn ,size) + (inst addi csp-tn ,temp-tn ,size)) + ) + #-gencgc + (t + (let ((,alloc-size ,size)) + (if (logbitp (1- lowtag-bits) ,lowtag) + (progn + (inst ori ,result-tn alloc-tn ,lowtag)) + (progn + (inst clrrwi ,result-tn alloc-tn lowtag-bits) + (inst ori ,result-tn ,result-tn ,lowtag))) + (if (numberp ,alloc-size) + (inst addi alloc-tn alloc-tn ,alloc-size) + (inst add alloc-tn alloc-tn ,alloc-size)))) + #+gencgc + (t + ;; Make temp-tn be the size + (cond ((numberp ,size) + (inst lr ,temp-tn ,size)) + (t + (move ,temp-tn ,size))) + + ;; Get the end of the current allocation region. + (load-symbol-value ,flag-tn *current-region-end-addr*) + ;; The object starts exactly where alloc-tn is, minus an tag + ;; bits, etc. + + ;; CAUTION: The C code depends on the exact order of + ;; instructions here. In particular, one instructions before + ;; the TW instruction must be an ADD or ADDI instruction, so it + ;; can figure out the size of the desired allocation. + (without-scheduling () + ;; Now make result-tn point at the end of the object, to + ;; figure out if we overflowed the current region. + (inst add alloc-tn alloc-tn ,temp-tn) + (inst clrrwi ,result-tn alloc-tn lowtag-bits) + ;; result-tn points to the new end of the region. Did we go past + ;; the actual end of the region? If so, we need a full alloc. + ;; The C code depends on this exact form of instruction. If + ;; either changes, you have to change the other appropriately! + (inst tw :lge ,result-tn ,flag-tn)) + + ;; At this point, result-tn points at the end of the object. + ;; Adjust to point to the beginning. + (inst sub ,result-tn ,result-tn ,temp-tn) + ;; Set the lowtag appropriately + (inst ori ,result-tn ,result-tn ,lowtag))))) (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size - &key (lowtag other-pointer-type)) + &key (lowtag other-pointer-type) + stack-p) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single word header having the specified Type-Code. The result is placed in @@ -218,7 +297,8 @@ `(pseudo-atomic (,flag-tn) (allocation ,result-tn (pad-data-block ,size) ,lowtag :temp-tn ,temp-tn - :flag-tn ,flag-tn) + :flag-tn ,flag-tn + :stack-p ,stack-p) (when ,type-code (inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code)) (storew ,temp-tn ,result-tn 0 ,lowtag)) -- GitLab