Commit 725ab9ee authored by dtc's avatar dtc
Browse files

Merge in changes to the x86 backend from the gencgc branch, allowing

common binaries to be run on both:

* The immediate-stack storage class has been removed, this is
unnecessary as the descriptor-stack SC can be used. It may have once
been part of some GC stragety to reduce the number of stack slots that
needed to be noted for a GC.

* The object allocation has been abstracted and cleaned up. This
should produce slightly faster smaller code with CGC, and can be
compiled to support inline allocation with GENCGC.  CGC compiled code
will run under GENCGC, and GENCGC binaries that don't use inline
allocation will run under CGC.

* A random hash is now placed in the unused symbol object slot (the
symbol-hash slot). This saves flushing the info cache at each GC, and
may have other uses for symbol based hash tables. Should help MP
safety.

* Common set of static symbols used by both CGC and GENCGC.

* Corrections to the stack-ref VOP; now returns lisp objects not
unsigned numbers. Required some patches to debug-int.

* Inline unsigned/signed byte 32 to bignum allocation enabled.

* Support for the x86 xadd instruction applied to instance slot and
symbol values - may be handy for some MP code.

* Bump up the FASL file version from 1 to 2.
parent 46f3e101
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/alloc.lisp,v 1.2 1997/02/10 16:59:54 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/alloc.lisp,v 1.3 1997/11/04 09:10:35 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -26,8 +26,7 @@
(define-assembly-routine
(move-from-signed)
((:temp eax dword-reg eax-offset)
(:temp ebx dword-reg ebx-offset)
(:temp ecx dword-reg ecx-offset))
(:temp ebx dword-reg ebx-offset))
(inst mov ebx eax)
(inst shl ebx 1)
(inst jmp :o bignum)
......@@ -36,8 +35,8 @@
(inst ret)
BIGNUM
(with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1))
(storew eax ebx bignum-digits-offset other-pointer-type))
(fixed-allocation ebx bignum-type (+ bignum-digits-offset 1))
(storew eax ebx bignum-digits-offset other-pointer-type)
(inst ret))
......@@ -45,8 +44,7 @@
(define-assembly-routine
(move-from-unsigned)
((:temp eax dword-reg eax-offset)
(:temp ebx dword-reg ebx-offset)
(:temp ecx dword-reg ecx-offset))
(:temp ebx dword-reg ebx-offset))
(inst test eax #xe0000000)
(inst jmp :nz bignum)
......@@ -66,11 +64,11 @@
(inst mov ebx eax)
;; Two word bignum
(with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 2))
(storew eax ebx bignum-digits-offset other-pointer-type))
(fixed-allocation ebx bignum-type (+ bignum-digits-offset 2))
(storew eax ebx bignum-digits-offset other-pointer-type)
(inst ret)
ONE-WORD-BIGNUM
(with-fixed-allocation (ebx ecx bignum-type (+ bignum-digits-offset 1))
(storew eax ebx bignum-digits-offset other-pointer-type))
(fixed-allocation ebx bignum-type (+ bignum-digits-offset 1))
(storew eax ebx bignum-digits-offset other-pointer-type)
(inst ret))
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/arith.lisp,v 1.4 1997/09/15 10:40:12 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/arith.lisp,v 1.5 1997/11/04 09:10:36 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -78,9 +78,8 @@
(move ecx res)
(with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type))
(fixed-allocation res bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type)
OKAY)
......@@ -99,8 +98,8 @@
(move ecx res)
(with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type))
(fixed-allocation res bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type)
OKAY)
(define-generic-arith-routine (* 30)
......@@ -120,15 +119,15 @@
(inst cmp x ecx)
(inst jmp :e SINGLE-WORD-BIGNUM)
(with-fixed-allocation (res ebx bignum-type (+ bignum-digits-offset 2))
(storew eax res bignum-digits-offset other-pointer-type)
(storew ecx res (1+ bignum-digits-offset) other-pointer-type))
(fixed-allocation res bignum-type (+ bignum-digits-offset 2))
(storew eax res bignum-digits-offset other-pointer-type)
(storew ecx res (1+ bignum-digits-offset) other-pointer-type)
(inst jmp DONE)
SINGLE-WORD-BIGNUM
(with-fixed-allocation (res ebx bignum-type (1+ bignum-digits-offset))
(storew eax res bignum-digits-offset other-pointer-type))
(fixed-allocation res bignum-type (1+ bignum-digits-offset))
(storew eax res bignum-digits-offset other-pointer-type)
(inst jmp DONE)
OKAY
......@@ -168,9 +167,8 @@
(inst shr res 2) ; sign bit is data - remove type bits
(move ecx res)
(with-fixed-allocation (res eax bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type))
(fixed-allocation res bignum-type (1+ bignum-digits-offset))
(storew ecx res bignum-digits-offset other-pointer-type)
OKAY)
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.2 1997/02/10 17:03:44 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.3 1997/11/04 09:10:37 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -32,24 +32,13 @@
((:arg type unsigned-reg eax-offset)
(:arg length any-reg ebx-offset)
(:arg words any-reg ecx-offset)
(:res result descriptor-reg edx-offset)
(:temp alloc dword-reg edi-offset))
#-cgc
(with-allocation (alloc)
(inst lea result (make-ea :byte :base alloc :disp other-pointer-type))
(inst add alloc
(+ (1- (ash 1 lowtag-bits)) (* vector-data-offset word-bytes)))
(inst add alloc words)
(inst and alloc (lognot vm:lowtag-mask)))
#+cgc
(progn
(inst mov alloc (+ (1- (ash 1 lowtag-bits))
(* vector-data-offset word-bytes)))
(inst add alloc words)
(inst and alloc (lognot vm:lowtag-mask))
(with-cgc-allocation(alloc alloc)
(inst lea result (make-ea :byte :base alloc :disp other-pointer-type))))
(:res result descriptor-reg edx-offset))
(inst mov result (+ (1- (ash 1 lowtag-bits))
(* vector-data-offset word-bytes)))
(inst add result words)
(inst and result (lognot vm:lowtag-mask))
(var-allocation result result)
(inst lea result (make-ea :byte :base result :disp other-pointer-type))
(storew type result 0 other-pointer-type)
(storew length result vector-length-slot other-pointer-type)
(inst ret))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.71 1997/02/08 17:22:40 pw Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.72 1997/11/04 09:10:41 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -915,12 +915,19 @@
; (format t "c-lra-fpc ~a ~a ~a~%" pc code pc-offset)
(values pc-offset code)))))
#+x86
(defun stack-ref-32 (stack offset)
(declare (type sys:system-area-pointer stack)
(type fixnum offset)
(optimize (speed 3) (safety 0)))
(kernel::get-lisp-obj-address (stack-ref stack offset)))
;;; maybe these should be generalized in xxx-vm.lisp
;;;(proclaim '(inline old-frame-pointer lisp-return-pc))
(defun old-frame-pointer(scp)
(declare (type (alien:alien (* unix:sigcontext)) scp))
(let* #+x86 ((cfp (vm:sigcontext-register scp vm::ebp-offset))
(ofp (kernel:stack-ref (int-sap cfp) vm::ocfp-save-offset)))
(ofp (stack-ref-32 (int-sap cfp) vm::ocfp-save-offset)))
#-x86 ((ofp (vm:sigcontext-register scp vm::ocfp-offset)))
(declare (type (unsigned-byte 32) #+x86 cfp ofp))
(int-sap ofp)))
......@@ -931,7 +938,7 @@
;;; return a value that can be used in computation
(declare (type (alien:alien (* unix:sigcontext)) scp))
(let* ((cfp (vm:sigcontext-register scp vm::ebp-offset))
(lra (kernel:stack-ref (int-sap cfp) vm::return-pc-save-offset)))
(lra (stack-ref-32 (int-sap cfp) vm::return-pc-save-offset)))
lra))
#-x86
(defun lisp-return-pc(scp)
......@@ -957,8 +964,8 @@
;; These return hopefully correct ofp ret values at a call site
(defun maybe-lisp-from-c(fp)
(declare (type system-area-pointer fp))
(let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset))
(s1 (kernel:stack-ref fp vm::return-pc-save-offset)))
(let ((s0 (stack-ref-32 fp vm::old-fp-save-offset))
(s1 (stack-ref-32 fp vm::return-pc-save-offset)))
(when (and (kernel:make-lisp-obj s0)(kernel:make-lisp-obj s1))
(let ((lisp-ofp (int-sap s0))
(lisp-lra (int-sap s1)))
......@@ -973,8 +980,8 @@
(defun maybe-lisp-from-lisp(fp)
(declare (type system-area-pointer fp))
(when (cstack-pointer-valid-p fp)
(let ((s0 (kernel:stack-ref fp vm::old-fp-save-offset))
(s1 (kernel:stack-ref fp vm::return-pc-save-offset)))
(let ((s0 (stack-ref-32 fp vm::old-fp-save-offset))
(s1 (stack-ref-32 fp vm::return-pc-save-offset)))
(when (and (kernel:make-lisp-obj s0)
(kernel:make-lisp-obj s1))
(let ((ofp (int-sap s0))
......@@ -1145,9 +1152,9 @@
(sub-access-debug-var-slot pointer loc escaped))))
(ecase stack-slot
(#.vm::ocfp-save-offset
(kernel:stack-ref pointer stack-slot))
(stack-ref-32 pointer stack-slot))
(#.vm::lra-save-offset
(kernel:make-lisp-obj (kernel:stack-ref pointer stack-slot)))))))
(kernel:stack-ref pointer stack-slot))))))
;;;
(defun (setf get-context-value) (value frame stack-slot loc)
......@@ -3082,9 +3089,8 @@
(system:int-sap (- (system:sap-int fp)
(* (+ (c::sc-offset-offset sc-offset) 2)
vm:word-bytes))) 0))
((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number)
(kernel:make-lisp-obj
(kernel:stack-ref fp (c::sc-offset-offset sc-offset))))
(#.vm:control-stack-sc-number
(kernel:stack-ref fp (c::sc-offset-offset sc-offset)))
(#.vm:base-char-stack-sc-number
(code-char
(system:sap-ref-32
......@@ -3299,7 +3305,7 @@
(system:sap+ fp (* (+ (c::sc-offset-offset sc-offset) 2)
(- vm:word-bytes))) 0)
(the double-float value)))
((#.vm:control-stack-sc-number #.vm:immediate-stack-sc-number)
(#.vm:control-stack-sc-number
(setf (kernel:stack-ref fp (c::sc-offset-offset sc-offset)) value))
(#.vm:base-char-stack-sc-number
(setf (system:sap-ref-32
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.21 1997/02/08 21:08:01 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/gc.lisp,v 1.22 1997/11/04 09:10:44 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -47,14 +47,14 @@
(c-var-frob current-dynamic-space-start "current_dynamic_space")
(declaim (inline dynamic-usage))
#-cgc
#-(or cgc gencgc)
(defun dynamic-usage ()
(the (unsigned-byte 32)
(- (system:sap-int (c::dynamic-space-free-pointer))
(current-dynamic-space-start))))
#+cgc
(c-var-frob dynamic-usage "cgc_bytes_allocated")
#+(or cgc gencgc)
(c-var-frob dynamic-usage "bytes_allocated")
(defun static-space-usage ()
(- (* lisp::*static-space-free-pointer* vm:word-bytes)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.50 1997/09/15 16:47:04 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.51 1997/11/04 09:10:45 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -518,7 +518,8 @@
(let ((loc (int-sap (- (sap-int ptr) offset))))
(cond ((= offset bytes-per-scrub-unit)
count)
((zerop (stack-ref loc 0))
((zerop (kernel::get-lisp-obj-address (stack-ref loc 0)))
; ((zerop (stack-ref loc 0))
(look ptr (+ offset vm:word-bytes) count))
(t
(scrub ptr offset (+ count vm:word-bytes)))))))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/symbol.lisp,v 1.22 1997/02/27 22:40:38 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/symbol.lisp,v 1.23 1997/11/04 09:10:46 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -99,7 +99,7 @@
#-gengc (make-symbol string)
#+gengc (%make-symbol (random most-positive-fixnum) string))
#+gengc
#+(or gengc x86)
(defun symbol-hash (symbol)
"Return the hash value for symbol."
(symbol-hash symbol))
......
......@@ -4,7 +4,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.25 1997/11/01 22:58:33 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.26 1997/11/04 09:10:51 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -543,6 +543,10 @@
(or *cold-symbol-allocation-space* *dynamic*)
vm:word-bits (1- vm:symbol-size) vm:symbol-header-type)))
(write-indexed symbol vm:symbol-value-slot unbound-marker)
(when (c:backend-featurep :x86)
(write-indexed symbol vm:symbol-hash-slot
(make-fixnum-descriptor
(1+ (random vm:target-most-positive-fixnum)))))
(write-indexed symbol vm:symbol-plist-slot *nil-descriptor*)
(write-indexed symbol vm:symbol-name-slot (string-to-core name *dynamic*))
(write-indexed symbol vm:symbol-package-slot *nil-descriptor*)
......@@ -750,7 +754,8 @@
(frob "*FP-CONSTANT-0D0*" "X86" (number-to-core 0d0))
(frob "*FP-CONSTANT-1D0*" "X86" (number-to-core 1d0))
(frob "*FP-CONSTANT-0S0*" "X86" (number-to-core 0s0))
(frob "*FP-CONSTANT-1S0*" "X86" (number-to-core 1s0)))))
(frob "*FP-CONSTANT-1S0*" "X86" (number-to-core 1s0))
(frob "*SCAVENGE-READ-ONLY-SPACE*" "X86" (cold-intern t)))))
;;; Make-Make-Package-Args -- Internal
;;;
......@@ -1684,9 +1689,12 @@
((and is-linux (gethash (concatenate 'string "PVE_stub_" name)
*cold-foreign-symbol-table* nil)))
;; Non-linux case
((let ((value (gethash name *cold-foreign-symbol-table* nil)))
#+irix (when (and (numberp value) (zerop value))
(warn "Not-really-defined foreign symbol: ~S" name))
(#-irix
(gethash name *cold-foreign-symbol-table* nil)
#+irix
(let ((value (gethash name *cold-foreign-symbol-table* nil)))
(when (and (numberp value) (zerop value))
(warn "Not-really-defined foreign symbol: ~S" name))
value))
((and is-linux (gethash (concatenate 'string "__libc_" name)
*cold-foreign-symbol-table* nil)))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.39 1997/11/01 22:58:35 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.40 1997/11/04 09:10:53 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -451,15 +451,20 @@
(defknown symbol-hash (symbol) index
(flushable movable))
#+x86
(defknown symbol-hash (symbol) cl::hash
(flushable movable))
(define-primitive-object (symbol :lowtag other-pointer-type
:header symbol-header-type
:alloc-trans
#-gengc make-symbol
#-x86 :alloc-trans
#-(or gengc x86) make-symbol
#+gengc %make-symbol)
(value :set-trans %set-symbol-value
:init :unbound)
#-gengc unused
#-(or gengc x86) unused
#+gengc (hash :init :arg)
#+x86 (hash)
(plist :ref-trans symbol-plist
:set-trans %set-symbol-plist
:init :null)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.34 1997/04/16 18:11:23 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.35 1997/11/04 09:10:48 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -289,16 +289,16 @@
(defun info-hash (x)
(cond
((symbolp x)
#-gengc (%sxhash-simple-string (symbol-name x))
#+gengc (symbol-hash x))
#-(or gengc x86) (%sxhash-simple-string (symbol-name x))
#+(or gengc x86) (symbol-hash x))
((and (listp x)
(eq (car x) 'setf)
(let ((next (cdr x)))
(when (listp next)
(let ((name (car next)))
(when (and (symbolp name) (null (cdr next)))
(logxor #-gengc (%sxhash-simple-string (symbol-name name))
#+gengc (symbol-hash name)
(logxor #-(or gengc x86) (%sxhash-simple-string (symbol-name name))
#+(or gengc x86) (symbol-hash name)
110680597)))))))
(t
(sxhash x))))
......@@ -459,8 +459,8 @@
(logand
(the fixnum
(logxor (the fixnum
#+gengc (info-hash ,name)
#-gengc (cache-hash-eq ,name))
#+(or gengc x86) (info-hash ,name)
#-(or gengc x86) (cache-hash-eq ,name))
(the fixnum (ash (the fixnum ,type) 7))))
#x3FF)))
......@@ -492,11 +492,11 @@
;;; Not needed with the gengc system, because we use an address independent
;;; hashing.
;;;
#-gengc
#-(or gengc x86)
(defun info-cache-gc-hook ()
(setq *cached-info-environment* nil))
;;;
#-gengc
#-(or gengc x86)
(pushnew 'info-cache-gc-hook *after-gc-hooks*)
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.2 1997/02/08 21:15:38 dtc Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.3 1997/11/04 09:10:55 dtc Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -16,6 +16,7 @@
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
;;; Enhancements/debugging by Douglas T. Crosher 1996,1996.
;;;
(in-package :x86)
......@@ -43,21 +44,13 @@
`(let ((reg
(sc-case ,tn
((any-reg descriptor-reg) ,tn)
((descriptor-stack immediate-stack)
((descriptor-stack)
(move temp ,tn)
temp))))
(storew reg ,list ,slot vm:list-pointer-type))))
(let ((cons-cells (if star (1- num) num)))
#-cgc
(with-allocation (temp)
(inst lea res
(make-ea :byte :base temp :disp list-pointer-type))
(inst add temp (* (pad-data-block cons-size) cons-cells)))
#+cgc
(with-cgc-allocation (temp (* (pad-data-block cons-size)
cons-cells))
(inst lea res
(make-ea :byte :base temp :disp list-pointer-type)))
(allocation res (* (pad-data-block cons-size) cons-cells))
(inst lea res (make-ea :byte :base res :disp list-pointer-type))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
......@@ -99,17 +92,12 @@
(inst shr unboxed word-shift)
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
#+nil ;; keep this here in case we load code in dynamic again
(with-allocation (temp)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))
(inst add temp boxed)
(inst add temp unboxed))
(progn ;; now loading code into static space cause it can't move
(load-symbol-value temp lisp::*static-space-free-pointer*)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))
(inst add temp boxed)
(inst add temp unboxed)
(store-symbol-value temp lisp::*static-space-free-pointer*))
;; now loading code into static space cause it can't move
(load-symbol-value temp lisp::*static-space-free-pointer*)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))
(inst add temp boxed)
(inst add temp unboxed)
(store-symbol-value temp lisp::*static-space-free-pointer*)
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
(storew boxed result 0 other-pointer-type)
......@@ -119,15 +107,11 @@
(storew temp result code-entry-points-slot other-pointer-type)
(storew temp result code-debug-info-slot other-pointer-type)))
;;; Top-Level-Forms have a short lifetime as they are unreachable
;;; once the loader eval's them. No point loading them in static
;;; space. This justs gives the loader a way to grab a chunk
;;; of the dynamic heap.
(define-vop (allocate-dynamic-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
(unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg)))
(:temporary (:sc dword-reg :from :eval) temp)
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc dword-reg :from (:argument 0)) boxed)
(:temporary (:sc dword-reg :from (:argument 1)) unboxed)
(:generator 100
......@@ -138,72 +122,52 @@
(inst shr unboxed word-shift)
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
#-cgc
(with-allocation (temp)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))
(inst add temp boxed)
(inst add temp unboxed))
#+cgc
(progn
(move temp boxed)
(inst add temp unboxed)
(with-cgc-allocation (temp temp)
(inst lea result (make-ea :byte :base temp :disp other-pointer-type))))
(inst mov result boxed)
(inst add result unboxed)
(var-allocation result result)
(inst lea result (make-ea :byte :base result :disp other-pointer-type))
(inst shl boxed (- type-bits word-shift))
(inst or boxed code-header-type)
(storew boxed result 0 other-pointer-type)
(storew unboxed result code-code-size-slot other-pointer-type)
(inst mov temp nil-value)
(storew temp result code-entry-points-slot other-pointer-type)
(storew temp result code-debug-info-slot other-pointer-type)))
(storew nil-value result code-entry-points-slot other-pointer-type)
(storew nil-value result code-debug-info-slot other-pointer-type)))
(define-vop (make-fdefn)
(:policy :fast-safe)
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:sc dword-reg) alloc)
(:results (result :scs (descriptor-reg) :from :argument))
(:generator 37
(with-fixed-allocation (result alloc fdefn-type fdefn-size)
(storew name result fdefn-name-slot other-pointer-type)
(storew nil-value result fdefn-function-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) result
fdefn-raw-addr-slot other-pointer-type))))
(fixed-allocation result fdefn-type fdefn-size)
(storew name result fdefn-name-slot other-pointer-type)
(storew nil-value result fdefn-function-slot other-pointer-type)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) result
fdefn-raw-addr-slot other-pointer-type)))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:args (function :to :save :scs (descriptor-reg)))
(:info length)
(:temporary (:sc any-reg) temp)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let ((size (+ length closure-info-offset)))
#-cgc
(with-allocation (temp)
(inst lea result (make-ea :byte :base temp :disp function-pointer-type))
(inst add temp (pad-data-block size))
(storew 0 temp 0)
(storew (logior (ash (1- size) type-bits) closure-header-type)
result 0 function-pointer-type))
#+cgc
(with-cgc-allocation(temp (pad-data-block size))
(inst lea result
(make-ea :byte :base temp :disp function-pointer-type))
(storew (logior (ash (1- size) type-bits) closure-header-type)
temp 0))
(loadw temp function closure-function-slot function-pointer-type)
(storew temp result closure-function-slot function-pointer-type))))
(allocation result (pad-data-block size))
(inst lea result (make-ea :byte :base result :disp function-pointer-type))
(storew (logior (ash (1- size) type-bits) closure-header-type)
result 0 function-pointer-type))
(loadw temp function closure-function-slot function-pointer-type)
(storew temp result clos