diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp index 37c3b12ff8c33ce9f0485c1f81308b7328b8e4a2..422bf4ae5b4e3e15e82caf8d51083d191b8ed031 100644 --- a/compiler/mips/alloc.lisp +++ b/compiler/mips/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/mips/alloc.lisp,v 1.22 1992/12/16 19:41:18 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.23 1993/05/07 07:27:37 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -81,9 +81,24 @@ (define-vop (list* list-or-list*) (:variant t)) +#+gengc +(def-source-transform list (&rest args) + (iterate repeat ((args args)) + (if args + `(cons ,(car args) ,(repeat (cdr args))) + nil))) + +#+gengc +(def-source-transform list* (arg &rest others) + (iterate repeat ((args (cons arg others))) + (if (cdr args) + `(cons ,(car args) ,(repeat (cdr args))) + (car args)))) + ;;;; Special purpose inline allocators. +#-gengc (define-vop (allocate-code-object) (:args (boxed-arg :scs (any-reg)) (unboxed-arg :scs (any-reg))) @@ -95,8 +110,7 @@ (:generator 100 (inst li ndescr (lognot lowtag-mask)) (inst addu boxed boxed-arg - (fixnum (1+ #-gengc code-trace-table-offset-slot - #+gengc code-debug-info-slot))) + (fixnum (1+ code-trace-table-offset-slot))) (inst and boxed ndescr) (inst srl unboxed unboxed-arg word-shift) (inst addu unboxed unboxed lowtag-mask) @@ -104,7 +118,6 @@ (inst sll ndescr boxed (- type-bits word-shift)) (inst or ndescr code-header-type) - #-gengc (pseudo-atomic (pa-flag) (inst or result alloc-tn other-pointer-type) (storew ndescr result 0 other-pointer-type) @@ -112,17 +125,34 @@ (storew null-tn result code-entry-points-slot other-pointer-type) (inst addu alloc-tn boxed) (inst addu alloc-tn unboxed)) - #+gengc - (without-scheduling () - (inst or result alloc-tn other-pointer-type) - (storew ndescr alloc-tn 0) - (storew unboxed alloc-tn code-code-size-slot) - (storew null-tn alloc-tn code-entry-points-slot) - (inst addu alloc-tn boxed) - (inst addu alloc-tn unboxed)) (storew null-tn result code-debug-info-slot other-pointer-type))) +#+gengc +(define-vop (allocate-code-object) + (:args (boxed :scs (any-reg)) + (unboxed :scs (any-reg))) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc any-reg :offset a0-offset :to (:result 0) :target result) + words) + (:temporary (:sc non-descriptor-reg :offset nl0-offset) lowtag) + (:temporary (:sc any-reg :offset nl1-offset) header) + (:temporary (:sc any-reg :offset nl2-offset) first-word) + (:generator 100 + (inst li lowtag (lognot lowtag-mask)) + (inst addu words boxed (fixnum (1+ code-debug-info-slot))) + (inst and words lowtag) + (inst addu first-word unboxed (fixnum 1)) + (inst and first-word lowtag) + (inst sll header words (- type-bits 2)) + (inst or header code-header-type) + (inst addu words first-word) + (inst jal (make-fixup 'large-alloc :assembly-routine)) + (inst li lowtag other-pointer-type) + (move result words) + (storew null-tn result code-entry-points-slot other-pointer-type) + (storew null-tn result code-debug-info-slot other-pointer-type))) + (define-vop (make-fdefn) (:policy :fast-safe) (:translate make-fdefn) @@ -143,6 +173,8 @@ (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:results (result :scs (descriptor-reg))) + #+gengc + (:ignore function length temp pa-flag result) (:generator 10 #-gengc (let ((size (+ length closure-info-offset))) @@ -152,15 +184,7 @@ (storew temp result 0 function-pointer-type)) (storew function result closure-function-slot function-pointer-type)) #+gengc - (let ((size (+ length closure-info-offset))) - (inst li temp (logior (ash (1- size) type-bits) closure-header-type)) - (without-scheduling () - (inst or result alloc-tn function-pointer-type) - (storew temp alloc-tn) - (inst addu alloc-tn (pad-data-block size))) - (inst addu temp function - (- (* function-code-offset word-bytes) function-pointer-type)) - (storew temp result closure-entry-point-slot function-pointer-type)))) + (error "MAKE-CLOSURE vop used in gengc system?"))) ;;; The compiler likes to be able to directly make value cells. ;;; @@ -189,7 +213,7 @@ (:ignore name) (:results (result :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) - (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:generator 4 #-gengc (pseudo-atomic (pa-flag :extra (pad-data-block words)) @@ -207,6 +231,7 @@ (storew temp alloc-tn)) (inst addu alloc-tn (pad-data-block words)))))) +#-gengc (define-vop (var-alloc) (:args (extra :scs (any-reg))) (:arg-types positive-fixnum) @@ -215,20 +240,36 @@ (:results (result :scs (descriptor-reg))) (:temporary (:scs (any-reg)) header) (:temporary (:scs (non-descriptor-reg)) bytes) - #-gengc (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) + (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag) (:generator 6 (inst addu bytes extra (* (1+ words) word-bytes)) (inst sll header bytes (- type-bits 2)) (inst addu header header (+ (ash -2 type-bits) type)) (inst srl bytes bytes lowtag-bits) (inst sll bytes bytes lowtag-bits) - #-gengc (pseudo-atomic (pa-flag) - (inst or result alloc-tn lowtag) - (storew header result 0 lowtag) - (inst addu alloc-tn alloc-tn bytes)) - #+gengc - (without-scheduling () (inst or result alloc-tn lowtag) (storew header result 0 lowtag) (inst addu alloc-tn alloc-tn bytes)))) + +#+gengc +(define-vop (var-alloc) + (:args (extra :scs (any-reg) :target nargs)) + (:arg-types positive-fixnum) + (:info name words type lowtag) + (:results (result :scs (descriptor-reg))) + (:temporary (:sc non-descriptor-reg :offset nl0-offset) nl0) + (:temporary (:sc non-descriptor-reg :offset nl1-offset) nl1) + (:temporary (:sc non-descriptor-reg :offset nl2-offset) nl2) + (:temporary (:sc any-reg :offset nargs-offset) nargs) + (:temporary (:sc descriptor-reg :offset a0-offset :target result + :from (:argument 0) :to (:result 0)) + a0) + (:ignore name nl2) + (:generator 10 + (inst addu nargs extra (fixnum words)) + (inst sll nl1 nargs (- type-bits word-shift)) + (inst addu nl1 (+ (ash -1 type-bits) type)) + (inst jal (make-fixup 'var-alloc :assembly-routine)) + (inst li nl0 lowtag) + (move result a0)))