99:
DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from
(let ((*print-circle* t)) (describe (make-hash-table)))
- is weird. (This is likely a pretty-printer problem which happens to
+ is weird,
+ #<HASH-TABLE :TEST EQL :COUNT 0 {90BBFC5}> is an . (EQL)
+ Its SIZE is 16.
+ Its REHASH-SIZE is 1.5. Its REHASH-THRESHOLD is . (1.0)
+ It holds 0 key/value pairs.
+ where the ". (EQL)" and ". (1.0)" substrings are screwups.
+ (This is likely a pretty-printer problem which happens to
be exercised by DESCRIBE, not actually a DESCRIBE problem.)
+100:
+ There's apparently a bug in CEILING optimization which caused
+ Douglas Crosher to patch the CMU CL version. Martin Atzmueller
+ applied the patches to SBCL and they didn't seem to cause problems
+ (as reported sbcl-devel 2001-05-04). However, since the patches
+ modify nontrivial code which was apparently written incorrectly
+ the first time around, until regression tests are written I'm not
+ comfortable merging the patches in the CVS version of SBCL.
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
Also, Christopher Hoover and William Lott wrote compiler/generic/vm-macs.lisp
to centralize information about machine-dependent macros and constants.
-Sean Hallgren converted compiler/generic/primtype.lisp for the Alpha.
+Sean Hallgren is credited with most of the Alpha backend. Julian
+Dolby created the CMU CL Alpha/linux port.
The CMU CL machine-independent disassembler (compiler/disassem.lisp)
was written by Miles Bader.
play nicely with ILISP. (Those patches have since disappeared from the
SBCL distribution because ILISP has since been patched to play nicely
with SBCL.) He also figured out how to get the CMU CL dynamic object
- file loading code to work under SBCL.
+ file loading code to work under SBCL. He ported CMU CL's Alpha
+ port to SBCL. He wrote code (e.g. grovel_headers.c and
+ stat_wrapper stuff) to handle machine-dependence and OS-dependence
+ automatically, reducing the amount of hand-tweaking required to
+ keep ports synchronized.
Cadabra, Inc. (later merged into GoTo.com):
They hired Bill Newman to do some consulting for them,
-name '*~' -or \
-name '#*#' -or \
-name '?*.x86f' -or \
+ -name '?*.axpf' -or \
-name '?*.lbytef' -or \
-name 'core' -or \
-name '?*.core' -or \
echo -n '(' >> $ltf
echo '//setting up "target"-named symlinks to designate target architecture'
-sbcl_arch=x86 # (the only possibility supported, at least as of sbcl-0.6.7)
-echo -n ":x86" >> $ltf # (again, the only possibility supported)
+# Currently supported: x86 alpha
+sbcl_arch=x86
+echo -n ":$sbcl_arch" >> $ltf
for d in src/compiler src/assembly; do
echo //setting up symlink $d/target
original_dir=`pwd`
rm -f Config
if [ `uname` = Linux ]; then
echo -n ' :linux' >> $ltf
- ln -s Config.x86-linux Config
+ ln -s Config.$sbcl_arch-linux Config
+ ( cd ../code && ln -sf $sbcl_arch-linux-types.lisp target-os-types.lisp )
elif uname | grep BSD; then
echo -n ' :bsd' >> $ltf
+ ( cd ../code && ln -sf $sbcl_arch-bsd-types.lisp target-os-types.lisp )
if [ `uname` = FreeBSD ]; then
echo -n ' :freebsd' >> $ltf
- ln -s Config.x86-freebsd Config
+ ln -s Config.$sbcl_arch-freebsd Config
elif [ `uname` = OpenBSD ]; then
echo -n ' :openbsd' >> $ltf
- ln -s Config.x86-openbsd Config
+ ln -s Config.$sbcl_arch-openbsd Config
else
echo unsupported BSD variant: `uname`
exit 1
"BINDING-STACK-START" "BINDING-STACK-END"
"CONTROL-STACK-START" "CONTROL-STACK-END"
"DYNAMIC-SPACE-START" "DYNAMIC-SPACE-END"
+ #!-gencgc "DYNAMIC-0-SPACE-START"
+ #!-gencgc "DYNAMIC-0-SPACE-END"
+ #!-gencgc "DYNAMIC-1-SPACE-START"
+ #!-gencgc "DYNAMIC-1-SPACE-END"
"READ-ONLY-SPACE-START" "READ-ONLY-SPACE-END"
"TARGET-BYTE-ORDER"
"TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE"
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle allocation of stuff we don't want to do inline.
+;;;
+;;; Written by William Lott.
+;;;
+
+(in-package "SB!VM")
+
+
+;;; Given that the pseudo-atomic sequence is so short, there is
+;;; nothing that qualifies. But we want to keep the file around
+;;; in case we decide to add something later.
+
--- /dev/null
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+;;;
+;;; **********************************************************************
+;;;
+;;; Stuff to handle simple cases for generic arithmetic.
+;;;
+;;; Written by William Lott.
+;;; Conversion by Sean Hallgren
+;;;
+
+(in-package "SB!VM")
+
+
+
+(define-assembly-routine (generic-+
+ (:cost 10)
+ (:return-style :full-call)
+ (:translate +)
+ (:policy :safe)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res (descriptor-reg any-reg) a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp temp2 non-descriptor-reg nl1-offset)
+ (:temp temp3 non-descriptor-reg nl2-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+ (inst addq x y res)
+
+ ; Check to see if we need a bignum
+ (inst sra res 31 temp)
+ (inst beq temp DONE)
+ (inst not temp temp)
+ (inst beq temp DONE)
+ (inst sra res 2 temp3)
+
+ ; From move-from-signed
+ (inst li 2 temp2)
+ (inst sra temp3 31 temp)
+ (inst cmoveq temp 1 temp2)
+ (inst not temp temp)
+ (inst cmoveq temp 1 temp2)
+ (inst sll temp2 type-bits temp2)
+ (inst bis temp2 bignum-type temp2)
+
+ (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+ (inst bis alloc-tn other-pointer-type res)
+ (storew temp2 res 0 other-pointer-type)
+ (storew temp3 res bignum-digits-offset other-pointer-type)
+ (inst srl temp3 32 temp)
+ (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+ DONE
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FUN
+ (inst ldl lip (static-function-offset 'two-arg-+) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip))
+
+
+(define-assembly-routine (generic--
+ (:cost 10)
+ (:return-style :full-call)
+ (:translate -)
+ (:policy :safe)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res (descriptor-reg any-reg) a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp temp2 non-descriptor-reg nl1-offset)
+ (:temp temp3 non-descriptor-reg nl2-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+ (inst subq x y res)
+
+ ; Check to see if we need a bignum
+ (inst sra res 31 temp)
+ (inst beq temp DONE)
+ (inst not temp temp)
+ (inst beq temp DONE)
+ (inst sra res 2 temp3)
+
+ ; From move-from-signed
+ (inst li 2 temp2)
+ (inst sra temp3 31 temp)
+ (inst cmoveq temp 1 temp2)
+ (inst not temp temp)
+ (inst cmoveq temp 1 temp2)
+ (inst sll temp2 type-bits temp2)
+ (inst bis temp2 bignum-type temp2)
+
+ (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+ (inst bis alloc-tn other-pointer-type res)
+ (storew temp2 res 0 other-pointer-type)
+ (storew temp3 res bignum-digits-offset other-pointer-type)
+ (inst srl temp3 32 temp)
+ (storew temp res (1+ bignum-digits-offset) other-pointer-type))
+ DONE
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FUN
+ (inst ldl lip (static-function-offset 'two-arg--) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip))
+
+
+(define-assembly-routine (generic-*
+ (:cost 25)
+ (:return-style :full-call)
+ (:translate *)
+ (:policy :safe)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res (descriptor-reg any-reg) a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp lo non-descriptor-reg nl1-offset)
+ (:temp hi non-descriptor-reg nl2-offset)
+ (:temp temp2 non-descriptor-reg nl3-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ ;; If either arg is not a fixnum, call the static function.
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FUN)
+
+ ;; Remove the tag from one arg so that the result will have the correct
+ ;; fixnum tag.
+ (inst sra x 2 temp)
+ (inst mulq temp y lo)
+ (inst sra lo 32 hi)
+ (inst sll lo 32 res)
+ (inst sra res 32 res)
+ ;; Check to see if the result will fit in a fixnum. (I.e. the high word
+ ;; is just 32 copies of the sign bit of the low word).
+ (inst sra res 31 temp)
+ (inst xor hi temp temp)
+ (inst beq temp DONE)
+ ;; Shift the double word hi:res down two bits into hi:low to get rid of the
+ ;; fixnum tag.
+ (inst sra lo 2 lo)
+ (inst sra lo 32 hi)
+
+ ;; Do we need one word or two? Assume two.
+ (inst li (logior (ash 2 type-bits) bignum-type) temp2)
+ (inst sra lo 31 temp)
+ (inst xor temp hi temp)
+ (inst bne temp two-words)
+
+ ;; Only need one word, fix the header.
+ (inst li (logior (ash 1 type-bits) bignum-type) temp2)
+ ;; Allocate one word.
+ (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
+ (inst bis alloc-tn other-pointer-type res)
+ (storew temp2 res 0 other-pointer-type))
+ ;; Store one word
+ (storew lo res bignum-digits-offset other-pointer-type)
+ ;; Out of here
+ (lisp-return lra lip :offset 2)
+
+ TWO-WORDS
+ ;; Allocate two words.
+ (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
+ (inst bis alloc-tn other-pointer-type res)
+ (storew temp2 res 0 other-pointer-type))
+ ;; Store two words.
+ (storew lo res bignum-digits-offset other-pointer-type)
+ (storew hi res (1+ bignum-digits-offset) other-pointer-type)
+ ;; Out of here
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FUN
+ (inst ldl lip (static-function-offset 'two-arg-*) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip)
+
+ DONE)
+
+\f
+;;;; Division.
+
+(define-assembly-routine (signed-truncate
+ (:note "(signed-byte 32) truncate")
+ (:cost 60)
+ (:policy :fast-safe)
+ (:translate truncate)
+ (:arg-types signed-num signed-num)
+ (:result-types signed-num signed-num))
+
+ ((:arg dividend signed-reg nl0-offset)
+ (:arg divisor signed-reg nl1-offset)
+
+ (:res quo signed-reg nl2-offset)
+ (:res rem signed-reg nl3-offset)
+
+ (:temp quo-sign signed-reg nl5-offset)
+ (:temp rem-sign signed-reg nargs-offset)
+ (:temp temp1 non-descriptor-reg nl4-offset))
+
+ (let ((error (generate-error-code nil division-by-zero-error
+ dividend divisor)))
+ (inst beq divisor error))
+
+ (inst xor dividend divisor quo-sign)
+ (inst move dividend rem-sign)
+ (let ((label (gen-label)))
+ (inst bge dividend label)
+ (inst subq zero-tn dividend dividend)
+ (emit-label label))
+ (let ((label (gen-label)))
+ (inst bge divisor label)
+ (inst subq zero-tn divisor divisor)
+ (emit-label label))
+ (inst move zero-tn rem)
+ (inst move zero-tn quo)
+ (inst sll dividend 32 dividend)
+
+ (dotimes (i 32)
+ (inst srl dividend 63 temp1)
+ (inst sll rem 1 rem)
+ (inst bis temp1 rem rem)
+ (inst cmple divisor rem temp1)
+ (inst sll quo 1 quo)
+ (inst bis temp1 quo quo)
+ (inst sll dividend 1 dividend)
+ (inst subq temp1 1 temp1)
+ (inst zap divisor temp1 temp1)
+ (inst subq rem temp1 rem))
+
+ (let ((label (gen-label)))
+ ;; If the quo-sign is negative, we need to negate quo.
+ (inst bge quo-sign label)
+ (inst subq zero-tn quo quo)
+ (emit-label label))
+ (let ((label (gen-label)))
+ ;; If the rem-sign is negative, we need to negate rem.
+ (inst bge rem-sign label)
+ (inst subq zero-tn rem rem)
+ (emit-label label)))
+
+\f
+;;;; Comparison routines.
+
+(macrolet
+ ((define-cond-assem-rtn (name translate static-fn cmp not-p)
+ `(define-assembly-routine (,name
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate ,translate)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res descriptor-reg a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FN)
+ (inst and y 3 temp)
+ (inst beq temp DO-COMPARE)
+
+ DO-STATIC-FN
+ (inst ldl lip (static-function-offset ',static-fn) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip)
+
+ DO-COMPARE
+ ,cmp
+ (inst move null-tn res)
+ (inst ,(if not-p 'bne 'beq) temp done)
+ (load-symbol res t)
+ DONE)))
+
+ (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)
+ (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))
+
+
+(define-assembly-routine (generic-eql
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate eql)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res descriptor-reg a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst cmpeq x y temp)
+ (inst bne temp RETURN-T)
+ (inst and x 3 temp)
+ (inst beq temp RETURN-NIL)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FN)
+
+ RETURN-NIL
+ (inst move null-tn res)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst ldl lip (static-function-offset 'eql) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip)
+
+ RETURN-T
+ (load-symbol res t))
+
+(define-assembly-routine (generic-=
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate =)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res descriptor-reg a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FN)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FN)
+ (inst cmpeq x y temp)
+ (inst bne temp RETURN-T)
+
+ (inst move null-tn res)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip)
+
+ RETURN-T
+ (load-symbol res t))
+
+(define-assembly-routine (generic-/=
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate /=)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) a0-offset)
+ (:arg y (descriptor-reg any-reg) a1-offset)
+
+ (:res res descriptor-reg a0-offset)
+
+ (:temp temp non-descriptor-reg nl0-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp nargs any-reg nargs-offset)
+ (:temp ocfp any-reg ocfp-offset))
+ (inst and x 3 temp)
+ (inst bne temp DO-STATIC-FN)
+ (inst and y 3 temp)
+ (inst bne temp DO-STATIC-FN)
+ (inst cmpeq x y temp)
+ (inst bne temp RETURN-NIL)
+
+ (load-symbol res t)
+ (lisp-return lra lip :offset 2)
+
+ DO-STATIC-FN
+ (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
+ (inst li (fixnumize 2) nargs)
+ (inst move cfp-tn ocfp)
+ (inst move csp-tn cfp-tn)
+ (inst jmp zero-tn lip)
+
+ RETURN-NIL
+ (inst move null-tn res))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the support routines for arrays and vectors.
+;;;
+;;; Written by William Lott.
+;;; Conversion by Sean Hallgren
+;;;
+(in-package "SB!VM")
+
+
+(define-assembly-routine (allocate-vector
+ (:policy :fast-safe)
+ (:translate allocate-vector)
+ (:arg-types positive-fixnum
+ positive-fixnum
+ positive-fixnum))
+ ((:arg type any-reg a0-offset)
+ (:arg length any-reg a1-offset)
+ (:arg words any-reg a2-offset)
+ (:res result descriptor-reg a0-offset)
+
+ (:temp ndescr non-descriptor-reg nl0-offset))
+ ;; This is kinda sleezy, changing words like this. But we can because
+ ;; the vop thinks it is temporary.
+ (inst addq words (+ (1- (ash 1 lowtag-bits))
+ (* vector-data-offset word-bytes))
+ words)
+ (inst li (lognot lowtag-mask) ndescr)
+ (inst and words ndescr words)
+ (inst srl type word-shift ndescr)
+
+ (pseudo-atomic ()
+ (inst bis alloc-tn other-pointer-type result)
+ (inst addq alloc-tn words alloc-tn)
+ (storew ndescr result 0 other-pointer-type)
+ (storew length result vector-length-slot other-pointer-type)))
+
+\f
+;;;; Hash primitives
+#|
+(define-assembly-routine (sxhash-simple-string
+ (:translate %sxhash-simple-string)
+ (:policy :fast-safe)
+ (:result-types positive-fixnum))
+ ((:arg string descriptor-reg a0-offset)
+ (:res result any-reg a0-offset)
+
+ (:temp length any-reg a1-offset)
+
+ (:temp lip interior-reg lip-offset)
+ (:temp accum non-descriptor-reg nl0-offset)
+ (:temp data non-descriptor-reg nl1-offset)
+ (:temp byte non-descriptor-reg nl2-offset)
+ (:temp retaddr non-descriptor-reg nl3-offset)
+ (:temp temp1 non-descriptor-reg nl4-offset))
+
+ ;; These are needed after we jump into sxhash-simple-substring.
+ (progn result lip accum data byte retaddr)
+
+ (inst li (make-fixup 'sxhash-simple-substring :assembly-routine) temp1)
+ (loadw length string vector-length-slot other-pointer-type)
+ (inst jmp zero-tn temp1
+ (make-fixup 'sxhash-simple-substring :assembly-routine)))
+
+(define-assembly-routine (sxhash-simple-substring
+ (:translate %sxhash-simple-substring)
+ (:policy :fast-safe)
+ (:arg-types * positive-fixnum)
+ (:result-types positive-fixnum))
+ ((:arg string descriptor-reg a0-offset)
+ (:arg length any-reg a1-offset)
+ (:res result any-reg a0-offset)
+
+ (:temp lip interior-reg lip-offset)
+ (:temp accum non-descriptor-reg nl0-offset)
+ (:temp data non-descriptor-reg nl1-offset)
+ (:temp byte non-descriptor-reg nl2-offset)
+ (:temp retaddr non-descriptor-reg nl3-offset))
+
+ ;; Save the return address
+ (inst subq lip code-tn retaddr)
+
+ ;; Get a pointer to the data.
+ (inst addq string
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ lip)
+ (move zero-tn accum)
+ (inst br zero-tn test)
+
+ loop
+
+ (inst and data #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+
+ (inst srl data 8 byte)
+ (inst and byte #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+
+ (inst srl data 16 byte)
+ (inst and byte #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+
+ (inst srl data 24 byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+
+ (inst addq lip 4 lip)
+
+ test
+
+ (inst subq length (fixnum 4) length)
+ (inst ldl data 0 lip)
+ (inst bge length loop)
+
+ (inst addq length (fixnum 3) length)
+ (inst beq length one-more)
+ (inst subq length (fixnum 1) length)
+ (inst beq length two-more)
+ (inst bne length done)
+
+ (inst srl data 16 byte)
+ (inst and byte #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+ (inst addq length (fixnum 1) length)
+
+ two-more
+
+ (inst subq length (fixnum 1) length)
+ (inst srl data 8 byte)
+ (inst and byte #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+ (inst addq length (fixnum 1) length)
+
+ one-more
+
+ (inst subq length (fixnum 1) length)
+ (inst and data #xff byte)
+ (inst xor accum byte accum)
+ (inst sll accum 5 byte)
+ (inst srl accum 27 accum)
+ (inst mskll accum 4 accum)
+ (inst bis accum byte accum)
+
+ done
+
+ (inst sll accum 5 result)
+ (inst mskll result 4 result)
+ (inst srl result 3 result)
+
+ ;; Restore the return address.
+ (inst addq code-tn retaddr lip))
+|#
\ No newline at end of file
--- /dev/null
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+;;;
+;;; **********************************************************************
+;;;
+(in-package "SB!VM")
+
+\f
+;;;; Return-multiple with other than one value
+
+#+sb-assembling ;; we don't want a vop for this one.
+(define-assembly-routine
+ (return-multiple
+ (:return-style :none))
+
+ ;; These four are really arguments.
+ ((:temp nvals any-reg nargs-offset)
+ (:temp vals any-reg nl0-offset)
+ (:temp ocfp any-reg nl1-offset)
+ (:temp lra descriptor-reg lra-offset)
+
+ ;; These are just needed to facilitate the transfer
+ (:temp lip interior-reg lip-offset)
+ (:temp count any-reg nl2-offset)
+ (:temp dst any-reg nl4-offset)
+ (:temp temp descriptor-reg l0-offset)
+
+ ;; These are needed so we can get at the register args.
+ (:temp a0 descriptor-reg a0-offset)
+ (:temp a1 descriptor-reg a1-offset)
+ (:temp a2 descriptor-reg a2-offset)
+ (:temp a3 descriptor-reg a3-offset)
+ (:temp a4 descriptor-reg a4-offset)
+ (:temp a5 descriptor-reg a5-offset))
+
+ ;; Note, because of the way the return-multiple vop is written, we can
+ ;; assume that we are never called with nvals == 1 and that a0 has already
+ ;; been loaded.
+ (inst ble nvals default-a0-and-on)
+ (inst ldl a1 (* 1 sb!vm:word-bytes) vals)
+ (inst subq nvals (fixnumize 2) count)
+ (inst ble count default-a2-and-on)
+ (inst ldl a2 (* 2 sb!vm:word-bytes) vals)
+ (inst subq nvals (fixnumize 3) count)
+ (inst ble count default-a3-and-on)
+ (inst ldl a3 (* 3 sb!vm:word-bytes) vals)
+ (inst subq nvals (fixnumize 4) count)
+ (inst ble count default-a4-and-on)
+ (inst ldl a4 (* 4 sb!vm:word-bytes) vals)
+ (inst subq nvals (fixnumize 5) count)
+ (inst ble count default-a5-and-on)
+ (inst ldl a5 (* 5 sb!vm:word-bytes) vals)
+ (inst subq nvals (fixnumize 6) count)
+ (inst ble count done)
+
+ ;; Copy the remaining args to the top of the stack.
+ (inst addq vals (* 6 sb!vm:word-bytes) vals)
+ (inst addq cfp-tn (* 6 sb!vm:word-bytes) dst)
+
+ LOOP
+ (inst ldl temp 0 vals)
+ (inst addq vals sb!vm:word-bytes vals)
+ (inst stl temp 0 dst)
+ (inst subq count (fixnumize 1) count)
+ (inst addq dst sb!vm:word-bytes dst)
+ (inst bne count loop)
+
+ (inst br zero-tn done)
+
+ DEFAULT-A0-AND-ON
+ (inst move null-tn a0)
+ (inst move null-tn a1)
+ DEFAULT-A2-AND-ON
+ (inst move null-tn a2)
+ DEFAULT-A3-AND-ON
+ (inst move null-tn a3)
+ DEFAULT-A4-AND-ON
+ (inst move null-tn a4)
+ DEFAULT-A5-AND-ON
+ (inst move null-tn a5)
+ DONE
+
+ ;; Clear the stack.
+ (move cfp-tn ocfp-tn)
+ (move ocfp cfp-tn)
+ (inst addq ocfp-tn nvals csp-tn)
+
+ ;; Return.
+ (lisp-return lra lip))
+
+\f
+;;;; tail-call-variable.
+
+#+sb-assembling ;; no vop for this one either.
+(define-assembly-routine
+ (tail-call-variable
+ (:return-style :none))
+
+ ;; These are really args.
+ ((:temp args any-reg nl0-offset)
+ (:temp lexenv descriptor-reg lexenv-offset)
+
+ ;; We need to compute this
+ (:temp nargs any-reg nargs-offset)
+
+ ;; These are needed by the blitting code.
+ (:temp src any-reg nl1-offset)
+ (:temp dst any-reg nl2-offset)
+ (:temp count any-reg cfunc-offset)
+ (:temp temp descriptor-reg l0-offset)
+
+ ;; Needed for the jump
+ (:temp lip interior-reg lip-offset)
+
+ ;; These are needed so we can get at the register args.
+ (:temp a0 descriptor-reg a0-offset)
+ (:temp a1 descriptor-reg a1-offset)
+ (:temp a2 descriptor-reg a2-offset)
+ (:temp a3 descriptor-reg a3-offset)
+ (:temp a4 descriptor-reg a4-offset)
+ (:temp a5 descriptor-reg a5-offset))
+
+
+ ;; Calculate NARGS (as a fixnum)
+ (inst subq csp-tn args nargs)
+
+ ;; Load the argument regs (must do this now, 'cause the blt might
+ ;; trash these locations)
+ (inst ldl a0 (* 0 sb!vm:word-bytes) args)
+ (inst ldl a1 (* 1 sb!vm:word-bytes) args)
+ (inst ldl a2 (* 2 sb!vm:word-bytes) args)
+ (inst ldl a3 (* 3 sb!vm:word-bytes) args)
+ (inst ldl a4 (* 4 sb!vm:word-bytes) args)
+ (inst ldl a5 (* 5 sb!vm:word-bytes) args)
+
+ ;; Calc SRC, DST, and COUNT
+ (inst subq nargs (fixnumize register-arg-count) count)
+ (inst addq args (* sb!vm:word-bytes register-arg-count) src)
+ (inst ble count done)
+ (inst addq cfp-tn (* sb!vm:word-bytes register-arg-count) dst)
+
+ LOOP
+ ;; Copy one arg.
+ (inst ldl temp 0 src)
+ (inst addq src sb!vm:word-bytes src)
+ (inst stl temp 0 dst)
+ (inst subq count (fixnumize 1) count)
+ (inst addq dst sb!vm:word-bytes dst)
+ (inst bgt count loop)
+
+ DONE
+ ;; We are done. Do the jump.
+ (progn
+ (loadw temp lexenv sb!vm:closure-function-slot sb!vm:function-pointer-type)
+ (lisp-jump temp lip)))
+
+\f
+;;;; Non-local exit noise.
+
+(define-assembly-routine
+ (unwind
+ (:translate %continue-unwind)
+ (:policy :fast-safe))
+ ((:arg block (any-reg descriptor-reg) a0-offset)
+ (:arg start (any-reg descriptor-reg) ocfp-offset)
+ (:arg count (any-reg descriptor-reg) nargs-offset)
+ (:temp lip interior-reg lip-offset)
+ (:temp lra descriptor-reg lra-offset)
+ (:temp cur-uwp any-reg nl0-offset)
+ (:temp next-uwp any-reg nl1-offset)
+ (:temp target-uwp any-reg nl2-offset)
+ (:temp temp1 non-descriptor-reg nl3-offset))
+ (declare (ignore start count))
+
+ (load-symbol-value cur-uwp sb!impl::*current-unwind-protect-block*)
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst beq block error))
+
+ (loadw target-uwp block sb!vm:unwind-block-current-uwp-slot)
+ (inst cmpeq cur-uwp target-uwp temp1)
+ (inst beq temp1 do-uwp)
+
+ (move block cur-uwp)
+
+ do-exit
+
+ (loadw cfp-tn cur-uwp sb!vm:unwind-block-current-cont-slot)
+ (loadw code-tn cur-uwp sb!vm:unwind-block-current-code-slot)
+ (progn
+ (loadw lra cur-uwp sb!vm:unwind-block-entry-pc-slot)
+ (lisp-return lra lip :frob-code nil))
+
+ do-uwp
+
+ (loadw next-uwp cur-uwp sb!vm:unwind-block-current-uwp-slot)
+ (store-symbol-value next-uwp sb!impl::*current-unwind-protect-block*)
+ (inst br zero-tn do-exit))
+
+
+(define-assembly-routine
+ throw
+ ((:arg target descriptor-reg a0-offset)
+ (:arg start any-reg ocfp-offset)
+ (:arg count any-reg nargs-offset)
+ (:temp catch any-reg a1-offset)
+ (:temp tag descriptor-reg a2-offset)
+ (:temp temp1 non-descriptor-reg nl0-offset))
+
+ (progn start count) ; We just need them in the registers.
+
+ (load-symbol-value catch sb!impl::*current-catch-block*)
+
+ loop
+
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst beq catch error))
+
+ (loadw tag catch sb!vm:catch-block-tag-slot)
+ (inst cmpeq tag target temp1)
+ (inst bne temp1 exit)
+ (loadw catch catch sb!vm:catch-block-previous-catch-slot)
+ (inst br zero-tn loop)
+
+ exit
+
+ (move catch target)
+ (inst li (make-fixup 'unwind :assembly-routine) temp1)
+ (inst jmp zero-tn temp1 (make-fixup 'unwind :assembly-routine)))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the machine specific support routines needed by
+;;; the file assembler.
+;;;
+(in-package "SB!VM")
+
+
+(!def-vm-support-routine generate-call-sequence (name style vop)
+ (ecase style
+ (:raw
+ (values
+ `((inst li (make-fixup ',name :assembly-routine) temp)
+ (inst jsr lip-tn temp))
+ '((:temporary (:sc non-descriptor-reg) temp))
+ nil))
+ (:full-call
+ (let ((temp (make-symbol "TEMP"))
+ (nfp-save (make-symbol "NFP-SAVE"))
+ (lra (make-symbol "LRA")))
+ (values
+ `((let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn ,vop)))
+ (when cur-nfp
+ (store-stack-tn ,nfp-save cur-nfp))
+ (inst compute-lra-from-code ,lra code-tn lra-label ,temp)
+ (note-next-instruction ,vop :call-site)
+ ; here
+ (inst li (make-fixup ',name :assembly-routine) temp1)
+ (inst jsr lip-tn temp1 (make-fixup ',name :assembly-routine))
+ (emit-return-pc lra-label)
+ (note-this-location ,vop :single-value-return)
+ (without-scheduling ()
+ (move ocfp-tn csp-tn)
+ (inst nop))
+ (inst compute-code-from-lra code-tn code-tn
+ lra-label ,temp)
+ (when cur-nfp
+ (maybe-load-stack-nfp-tn cur-nfp ,nfp-save temp1))))
+ `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))
+ ,temp)
+ (:temporary (:sc descriptor-reg :offset lra-offset
+ :from (:eval 0) :to (:eval 1))
+ ,lra)
+ (:temporary (:scs (control-stack) :offset nfp-save-offset)
+ ,nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp1)
+ (:save-p t)))))
+ (:none
+ (values
+ `((inst li (make-fixup ',name :assembly-routine) temp)
+ (inst jsr lip-tn temp (make-fixup ',name :assembly-routine)))
+ '((:temporary (:scs (non-descriptor-reg)) temp))
+ nil))))
+
+
+(!def-vm-support-routine generate-return-sequence (style)
+ (ecase style
+ (:raw
+ `((inst ret zero-tn lip-tn)))
+ (:full-call
+ `((lisp-return (make-random-tn :kind :normal
+ :sc (sc-or-lose
+ 'descriptor-reg)
+ :offset lra-offset)
+ lip-tn :offset 2)))
+ (:none)))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+
+(in-package "SB!VM")
+
+(export '(#||# fixup-code-object internal-error-arguments
+ context-program-counter context-register
+ context-float-register context-floating-point-modes
+ extern-alien-name sanctify-for-execution))
+
+\f
+(defvar *number-of-signals* 64)
+(defvar *bits-per-word* 64)
+
+;;; see x86-vm.lisp
+(def-alien-type os-context-t (struct os-context-t-struct))
+
+\f
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+ "Returns a string describing the type of the local machine."
+ "Alpha")
+(defun machine-version ()
+ "Returns a string describing the version of the local machine."
+ "Alpha")
+
+
+\f
+;;; FIXUP-CODE-OBJECT -- Interface
+;;;
+(defun fixup-code-object (code offset value kind)
+ (unless (zerop (rem offset word-bytes))
+ (error "Unaligned instruction? offset=#x~X." offset))
+ (sb!sys:without-gcing
+ (let ((sap (truly-the system-area-pointer
+ (%primitive sb!kernel::code-instructions code))))
+ (ecase kind
+ (:jmp-hint
+ (assert (zerop (ldb (byte 2 0) value)))
+ #+nil
+ (setf (sap-ref-16 sap offset)
+ (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2)))))
+ (:bits-63-48
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
+ (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
+ (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value))
+ (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value))))
+ (:bits-47-32
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
+ (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value))
+ (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value))))
+ (:ldah
+ (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
+ (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value))
+ (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value))))
+ (:lda
+ (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value))
+ (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))))))
+
+
+\f
+
+;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
+;;; hacked for types. The alpha has 64-bit registers, so these
+;;; potentially return 64 bit numbers (which means bignums ... ew)
+;;; We think that 99 times of 100 (i.e. unless something is badly wrong)
+;;; we'll get answers that fit in 32 bits anyway.
+
+;;; Which probably won't help us stop passing bignums around as the
+;;; compiler can't prove they fit in 32 bits. But maybe the stuff it
+;;; does on x86 to unbox 32-bit constants happens magically for 64-bit
+;;; constants here. Just maybe.
+
+;;; see also x86-vm for commentary on signed vs unsigned.
+
+(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
+ (context (* os-context-t)))
+
+(defun context-pc (context)
+ (declare (type (alien (* os-context-t)) context))
+ (int-sap (deref (context-pc-addr context))))
+
+(def-alien-routine ("os_context_register_addr" context-register-addr)
+ (* unsigned-long)
+ (context (* os-context-t))
+ (index int))
+
+;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
+;;; (Are they used in anything time-critical, or just the debugger?)
+(defun context-register (context index)
+ (declare (type (alien (* os-context-t)) context))
+ (deref (context-register-addr context index)))
+
+(defun %set-context-register (context index new)
+(declare (type (alien (* os-context-t)) context))
+(setf (deref (context-register-addr context index))
+ new))
+
+;;; Like CONTEXT-REGISTER, but returns the value of a float register.
+;;; FORMAT is the type of float to return.
+
+;;; whether COERCE actually knows how to make a float out of a long
+;;; is another question. This stuff still needs testing
+(def-alien-routine ("os_context_fpregister_addr" context-float-register-addr)
+ (* long)
+ (context (* os-context-t))
+ (index int))
+(defun context-float-register (context index format)
+ (declare (type (alien (* os-context-t)) context))
+ (coerce (deref (context-float-register-addr context index)) format))
+(defun %set-context-float-register (context index format new)
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (context-float-register-addr context index))
+ (coerce new format)))
+
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+ ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
+ ;; POSIXness and (at the Lisp level) opaque signal contexts,
+ ;; this is stubified. It needs to be rewritten as an
+ ;; alien function.
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+
+ ;; old code for Linux:
+ #+nil
+ (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
+ (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
+ ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
+ ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
+ (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
+ ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
+ ;; Simulate floating-point-modes VOP.
+ (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
+
+ 0)
+\f
+;;;; INTERNAL-ERROR-ARGUMENTS
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream. This is e.g.
+;;; 4 23 254 240 2 0 0 0
+;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
+;;; length data (everything is an octet)
+;;; (pc)
+;;; (example from undefined_tramp: "(gdb) x/40ub 0x10148" for yourself
+;;; to replicate)
+
+(defun internal-error-arguments (context)
+ (declare (type (alien (* os-context-t)) context))
+ (sb!int::/show0 "entering INTERNAL-ERROR-ARGUMENTS")
+ (let ((pc (context-pc context)))
+ (declare (type system-area-pointer pc))
+ ;; pc is a SAP pointing at - or actually, shortly after -
+ ;; the instruction that got us into this mess in the first place
+ (let* ((length (sap-ref-8 pc 4))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (copy-from-system-area pc (* sb!vm:byte-bits 5)
+ vector (* sb!vm:word-bits
+ sb!vm:vector-data-offset)
+ (* length sb!vm:byte-bits))
+ (let* ((index 0)
+ (error-number (sb!c::read-var-integer vector index)))
+ (collect ((sc-offsets))
+ (loop
+ (when (>= index length)
+ (return))
+ (sc-offsets (sb!c::read-var-integer vector index)))
+ (values error-number (sc-offsets)))))))
+
+\f
+;;; EXTERN-ALIEN-NAME -- interface.
+;;;
+;;; The loader uses this to convert alien names to the form they occure in
+;;; the symbol table (for example, prepending an underscore). On the Alpha
+;;; we don't do anything.
+;;;
+(defun extern-alien-name (name)
+ (declare (type simple-base-string name))
+ name)
+
+
+\f
+;;; SANCTIFY-FOR-EXECUTION -- Interface.
+;;;
+;;; Do whatever is necessary to make the given code component executable.
+;;;
+
+;;; XXX do we really not have to flush caches or something here? I need
+;;; an architecture manual
+(defun sanctify-for-execution (component)
+ (declare (ignore component))
+ nil)
+++ /dev/null
-;;;; extensions which are needed in order to (cross-)compile target-only code
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!IMPL")
-
-;;; Lots of code wants to get to the KEYWORD package or the
-;;; COMMON-LISP package without a lot of fuss, so we cache them in
-;;; variables. TO DO: How much does this actually buy us? It sounds
-;;; sensible, but I don't know for sure that it saves space or time..
-;;; -- WHN 19990521
-;;;
-;;; (The initialization forms here only matter on the cross-compilation
-;;; host; In the target SBCL, these variables are set in cold init.)
-(declaim (type package *cl-package* *keyword-package*))
-(defvar *cl-package* (find-package "COMMON-LISP"))
-(defvar *keyword-package* (find-package "KEYWORD"))
-
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-;;;
-;;; FIXME: This implementation will hang on circular list structure.
-;;; Since this is an error-checking utility, i.e. its job is to deal
-;;; with screwed-up input, it'd be good style to fix it so that it can
-;;; deal with circular list structure.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;; Return true if X is a proper list whose length is between MIN and
- ;; MAX (inclusive).
- (defun proper-list-of-length-p (x min &optional (max min))
- (cond ((minusp max)
- nil)
- ((null x)
- (zerop min))
- ((consp x)
- (and (plusp max)
- (proper-list-of-length-p (cdr x)
- (if (plusp (1- min))
- (1- min)
- 0)
- (1- max))))
- (t nil))))
-\f
-;;;; the COLLECT macro
-
-;;; helper functions for COLLECT, which become the expanders of the
-;;; MACROLET definitions created by COLLECT
-;;;
-;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
-;;;
-;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
-;;; is the pointer to the current tail of the list, or NIL if the list
-;;; is empty.
-(defun collect-normal-expander (n-value fun forms)
- `(progn
- ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
- ,n-value))
-(defun collect-list-expander (n-value n-tail forms)
- (let ((n-res (gensym)))
- `(progn
- ,@(mapcar #'(lambda (form)
- `(let ((,n-res (cons ,form nil)))
- (cond (,n-tail
- (setf (cdr ,n-tail) ,n-res)
- (setq ,n-tail ,n-res))
- (t
- (setq ,n-tail ,n-res ,n-value ,n-res)))))
- forms)
- ,n-value)))
-
-;;; the ultimate collection macro...
-(defmacro collect (collections &body body)
- #!+sb-doc
- "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
- Collect some values somehow. Each of the collections specifies a bunch of
- things which collected during the evaluation of the body of the form. The
- name of the collection is used to define a local macro, a la MACROLET.
- Within the body, this macro will evaluate each of its arguments and collect
- the result, returning the current value after the collection is done. The
- body is evaluated as a PROGN; to get the final values when you are done, just
- call the collection macro with no arguments.
-
- INITIAL-VALUE is the value that the collection starts out with, which
- defaults to NIL. FUNCTION is the function which does the collection. It is
- a function which will accept two arguments: the value to be collected and the
- current collection. The result of the function is made the new value for the
- collection. As a totally magical special-case, FUNCTION may be COLLECT,
- which tells us to build a list in forward order; this is the default. If an
- INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd onto the
- end. Note that FUNCTION may be anything that can appear in the functional
- position, including macros and lambdas."
-
- (let ((macros ())
- (binds ()))
- (dolist (spec collections)
- (unless (proper-list-of-length-p spec 1 3)
- (error "Malformed collection specifier: ~S." spec))
- (let* ((name (first spec))
- (default (second spec))
- (kind (or (third spec) 'collect))
- (n-value (gensym (concatenate 'string
- (symbol-name name)
- "-N-VALUE-"))))
- (push `(,n-value ,default) binds)
- (if (eq kind 'collect)
- (let ((n-tail (gensym (concatenate 'string
- (symbol-name name)
- "-N-TAIL-"))))
- (if default
- (push `(,n-tail (last ,n-value)) binds)
- (push n-tail binds))
- (push `(,name (&rest args)
- (collect-list-expander ',n-value ',n-tail args))
- macros))
- (push `(,name (&rest args)
- (collect-normal-expander ',n-value ',kind args))
- macros))))
- `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
-\f
-;;; This function can be used as the default value for keyword
-;;; arguments that must be always be supplied. Since it is known by
-;;; the compiler to never return, it will avoid any compile-time type
-;;; warnings that would result from a default value inconsistent with
-;;; the declared type. When this function is called, it signals an
-;;; error indicating that a required &KEY argument was not supplied.
-;;; This function is also useful for DEFSTRUCT slot defaults
-;;; corresponding to required arguments.
-(declaim (ftype (function () nil) required-argument))
-(defun required-argument ()
- #!+sb-doc
- (/show0 "entering REQUIRED-ARGUMENT")
- (error "A required &KEY argument was not supplied."))
-\f
-;;; "the ultimate iteration macro"
-;;;
-;;; note for Schemers: This seems to be identical to Scheme's "named LET".
-(defmacro named-let (name binds &body body)
- #!+sb-doc
- (dolist (x binds)
- (unless (proper-list-of-length-p x 2)
- (error "Malformed ITERATE variable spec: ~S." x)))
- `(labels ((,name ,(mapcar #'first binds) ,@body))
- (,name ,@(mapcar #'second binds))))
-
-;;; ONCE-ONLY is a utility useful in writing source transforms and
-;;; macros. It provides a concise way to wrap a LET around some code
-;;; to ensure that some forms are only evaluated once.
-;;;
-;;; Create a LET* which evaluates each value expression, binding a
-;;; temporary variable to the result, and wrapping the LET* around the
-;;; result of the evaluation of BODY. Within the body, each VAR is
-;;; bound to the corresponding temporary variable.
-(defmacro once-only (specs &body body)
- (named-let frob ((specs specs)
- (body body))
- (if (null specs)
- `(progn ,@body)
- (let ((spec (first specs)))
- ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
- (unless (proper-list-of-length-p spec 2)
- (error "malformed ONCE-ONLY binding spec: ~S" spec))
- (let* ((name (first spec))
- (exp-temp (gensym (symbol-name name))))
- `(let ((,exp-temp ,(second spec))
- (,name (gensym "ONCE-ONLY-")))
- `(let ((,,name ,,exp-temp))
- ,,(frob (rest specs) body))))))))
-\f
-;;;; some old-fashioned functions. (They're not just for old-fashioned
-;;;; code, they're also used as optimized forms of the corresponding
-;;;; general functions when the compiler can prove that they're
-;;;; equivalent.)
-
-;;; like (MEMBER ITEM LIST :TEST #'EQ)
-(defun memq (item list)
- #!+sb-doc
- "Returns tail of LIST beginning with first element EQ to ITEM."
- ;; KLUDGE: These could be and probably should be defined as
- ;; (MEMBER ITEM LIST :TEST #'EQ)),
- ;; but when I try to cross-compile that, I get an error from
- ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
- ;; comments for that error say it "is probably a botched interpreter stub".
- ;; Rather than try to figure that out, I just rewrote this function from
- ;; scratch. -- WHN 19990512
- (do ((i list (cdr i)))
- ((null i))
- (when (eq (car i) item)
- (return i))))
-
-;;; like (ASSOC ITEM ALIST :TEST #'EQ)
-(defun assq (item alist)
- #!+sb-doc
- "Return the first pair of ALIST where ITEM is EQ to the key of the pair."
- ;; KLUDGE: CMU CL defined this with
- ;; (DECLARE (INLINE ASSOC))
- ;; (ASSOC ITEM ALIST :TEST #'EQ))
- ;; which is pretty, but which would have required adding awkward
- ;; build order constraints on SBCL (or figuring out some way to make
- ;; inline definitions installable at build-the-cross-compiler time,
- ;; which was too ambitious for now). Rather than mess with that, we
- ;; just define ASSQ explicitly in terms of more primitive
- ;; operations:
- (dolist (pair alist)
- (when (eq (car pair) item)
- (return pair))))
-
-(defun delq (item list)
- #!+sb-doc
- "Delete all LIST entries EQ to ITEM (destructively modifying LIST), and
- return the modified LIST."
- (let ((list list))
- (do ((x list (cdr x))
- (splice '()))
- ((endp x) list)
- (cond ((eq item (car x))
- (if (null splice)
- (setq list (cdr x))
- (rplacd splice (cdr x))))
- (t (setq splice x)))))) ; Move splice along to include element.
-
-
-;; (defmacro posq (item list) `(position ,item ,list :test #'eq))
-(defun posq (item list)
- #!+sb-doc
- "Returns the position of the first element EQ to ITEM."
- (do ((i list (cdr i))
- (j 0 (1+ j)))
- ((null i))
- (when (eq (car i) item)
- (return j))))
-
-;; (defmacro neq (x y) `(not (eq ,x ,y)))
-(defun neq (x y) (not (eq x y)))
;; FIXME: This list of modes should be defined in one place and
;; explicitly shared between here and REINIT.
+ ;;
+ ;; FIXME: In CMU CL, this is done "here" (i.e. in the analogous
+ ;; lispinit.lisp code) for every processor architecture. But Daniel
+ ;; Barlow's Alpha patches suppress it for Alpha. Why the difference?
+ #!+alpha
(set-floating-point-modes :traps '(:overflow
#!-x86 :underflow
:invalid
#!+sb-doc
(:documentation "There is no usable debugging information available.")
(:report (lambda (condition stream)
- (declare (ignore condition))
(fresh-line stream)
(format stream
"no debug information available for ~S~%"
;;;; data structures created by the compiler. Whenever comments
;;;; preface an object or type with "compiler", they refer to the
;;;; internal compiler thing, not to the object or type with the same
-;;;; name in the "DI" package.
+;;;; name in the "SB-DI" package.
;;;; DEBUG-VARs
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
-#!-(or gengc x86)
-;;; FIXME: The original CMU CL code had support for this case, but it
-;;; must have been fairly stale even in CMU CL, since it had
-;;; references to the MIPS package, and there have been enough
-;;; relevant changes in SBCL (particularly using
-;;; POSIX/SIGACTION0-style signal context instead of BSD-style
-;;; sigcontext) that this code is unmaintainable (since as of
-;;; sbcl-0.6.7, and for the foreseeable future, we can't test it,
-;;; since we only support X86 and its gencgc).
-;;;
-;;; If we restore this case, the best approach would be to go back to
-;;; the original CMU CL code and start from there.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
#!+x86
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(return
(values code pc-offset context))))))))))
+#!-x86
+(defun find-escaped-frame (frame-pointer)
+ (declare (type system-area-pointer frame-pointer))
+ (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil))
+ (sb!alien:with-alien
+ ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
+ (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
+ (when (= (sap-int frame-pointer)
+ (sb!vm:context-register scp sb!vm::cfp-offset))
+ (without-gcing
+ (let ((code (code-object-from-bits
+ (sb!vm:context-register scp sb!vm::code-offset))))
+ (when (symbolp code)
+ (return (values code 0 scp)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:word-bytes))
+ (pc-offset
+ (- (sap-int (sb!vm:context-pc scp))
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-type)
+ code-header-len)))
+ ;; Check to see whether we were executing in a branch
+ ;; delay slot.
+ #!+(or pmax sgi) ; pmax only (and broken anyway)
+ (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
+ (incf pc-offset sb!vm:word-bytes))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm:word-bytes))
+ ;; We were in an assembly routine. Therefore, use the
+ ;; LRA as the pc.
+ (setf pc-offset
+ (- (sb!vm:context-register scp sb!vm::lra-offset)
+ (get-lisp-obj-address code)
+ code-header-len)))
+ (return
+ (if (eq (%code-debug-info code) :bogus-lra)
+ (let ((real-lra (code-header-ref code
+ real-lra-slot)))
+ (values (lra-code-header real-lra)
+ (get-header-data real-lra)
+ nil))
+ (values code pc-offset scp)))))))))))
+
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
;;; cell if the variable is both closed over and set.
(defun access-compiled-debug-var-slot (debug-var frame)
+ (declare (optimize (speed 1)))
(let ((escaped (compiled-frame-escaped frame)))
(if escaped
- (sub-access-debug-var-slot
- (frame-pointer frame)
- (compiled-debug-var-sc-offset debug-var)
- escaped)
- (sub-access-debug-var-slot
- (frame-pointer frame)
- (or (compiled-debug-var-save-sc-offset debug-var)
- (compiled-debug-var-sc-offset debug-var))))))
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (compiled-debug-var-sc-offset debug-var)
+ escaped)
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (or (compiled-debug-var-save-sc-offset debug-var)
+ (compiled-debug-var-sc-offset debug-var))))))
;;; a helper function for working with possibly-invalid values:
;;; Do (MAKE-LISP-OBJ VAL) only if the value looks valid.
(make-lisp-obj val)
:invalid-object))
-;;; CMU CL had
-;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
-;;; code for this case.
#!-x86
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (error "hopelessly stale"))
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+ (macrolet ((with-escaped-value ((var) &body forms)
+ `(if escaped
+ (let ((,var (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))))
+ ,@forms)
+ :invalid-value-for-unescaped-register-storage))
+ (escaped-float-value (format)
+ `(if escaped
+ (sb!vm:context-float-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset)
+ ',format)
+ :invalid-value-for-unescaped-register-storage))
+ (with-nfp ((var) &body body)
+ `(let ((,var (if escaped
+ (sb!sys:int-sap
+ (sb!vm:context-register escaped
+ sb!vm::nfp-offset))
+ #!-alpha
+ (sb!sys:sap-ref-sap fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
+ #!+alpha
+ (sb!vm::make-number-stack-pointer
+ (sb!sys:sap-ref-32 fp (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
+ ,@body)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number
+ #.sb!vm:descriptor-reg-sc-number
+ #!+rt #.sb!vm:word-pointer-reg-sc-number)
+ (sb!sys:without-gcing
+ (with-escaped-value (val) (sb!kernel:make-lisp-obj val))))
+
+ (#.sb!vm:base-char-reg-sc-number
+ (with-escaped-value (val)
+ (code-char val)))
+ (#.sb!vm:sap-reg-sc-number
+ (with-escaped-value (val)
+ (sb!sys:int-sap val)))
+ (#.sb!vm:signed-reg-sc-number
+ (with-escaped-value (val)
+ (if (logbitp (1- sb!vm:word-bits) val)
+ (logior val (ash -1 sb!vm:word-bits))
+ val)))
+ (#.sb!vm:unsigned-reg-sc-number
+ (with-escaped-value (val)
+ val))
+ (#.sb!vm:non-descriptor-reg-sc-number
+ (error "Local non-descriptor register access?"))
+ (#.sb!vm:interior-reg-sc-number
+ (error "Local interior register access?"))
+ (#.sb!vm:single-reg-sc-number
+ (escaped-float-value single-float))
+ (#.sb!vm:double-reg-sc-number
+ (escaped-float-value double-float))
+ #!+long-float
+ (#.sb!vm:long-reg-sc-number
+ (escaped-float-value long-float))
+ (#.sb!vm:complex-single-reg-sc-number
+ (if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'single-float)
+ (sb!vm:context-float-register
+ escaped (1+ (sb!c:sc-offset-offset sc-offset)) 'single-float))
+ :invalid-value-for-unescaped-register-storage))
+ (#.sb!vm:complex-double-reg-sc-number
+ (if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
+ (sb!vm:context-float-register
+ escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #-sparc 1)
+ 'double-float))
+ :invalid-value-for-unescaped-register-storage))
+ #!+long-float
+ (#.sb!vm:complex-long-reg-sc-number
+ (if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
+ (sb!vm:context-float-register
+ escaped (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+ 'long-float))
+ :invalid-value-for-unescaped-register-storage))
+ (#.sb!vm:single-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:double-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:complex-single-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-single nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-double nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (with-nfp (nfp)
+ (complex
+ (sb!sys:sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (sb!sys:sap-ref-long nfp (* (+ (sb!c:sc-offset-offset sc-offset)
+ #!+sparc 4)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:control-stack-sc-number
+ (sb!kernel:stack-ref fp (sb!c:sc-offset-offset sc-offset)))
+ (#.sb!vm:base-char-stack-sc-number
+ (with-nfp (nfp)
+ (code-char (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:signed-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))))
+ (#.sb!vm:sap-stack-sc-number
+ (with-nfp (nfp)
+ (sb!sys:sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes)))))))
#!+x86
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+++ /dev/null
-;;;; This file contains definitions and declarations for the
-;;;; EXTENSIONS package which must be available at early cross-compile
-;;;; time, and perhaps also some things which might as well be built
-;;;; at cross-compile time even if they're not strictly needed, since
-;;;; that's harmless. Things which can't be built at cross-compile
-;;;; time (e.g. because they need machinery which only exists inside
-;;;; CMU CL's implementation of the LISP package) do not belong in
-;;;; this file.
-
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!IMPL")
-
-;;; something not EQ to anything we might legitimately READ
-(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
-
-;;; a type used for indexing into arrays, and for related quantities
-;;; like lengths of lists
-;;;
-;;; It's intentionally limited to one less than the
-;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
-;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
-;;; that lets the system know it can increment a value of this type
-;;; without having to worry about using a bignum to represent the
-;;; result.
-;;;
-;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
-;;; bound because ANSI specifies it as an exclusive bound.)
-(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
-
-;;; the default value used for initializing character data. The ANSI
-;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
-;;; because it's not in the ANSI table of portable characters.
-(defconstant default-init-char #\space)
-
-;;; CHAR-CODE values for ASCII characters which we care about but
-;;; which aren't defined in section "2.1.3 Standard Characters" of the
-;;; ANSI specification for Lisp
-;;;
-;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
-;;; FOO-CHAR-CODE). I suspect that the current implementation is
-;;; expanding this idiom into a full call to CODE-CHAR, which is an
-;;; annoying overhead. I should check whether this is happening, and
-;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
-;;; (or just find a nicer way of expressing characters portably?) --
-;;; WHN 19990713
-(defconstant bell-char-code 7)
-(defconstant tab-char-code 9)
-(defconstant form-feed-char-code 12)
-(defconstant return-char-code 13)
-(defconstant escape-char-code 27)
-(defconstant rubout-char-code 127)
-\f
-;;;; miscellaneous iteration extensions
-
-(defmacro dovector ((elt vector &optional result) &rest forms)
- #!+sb-doc
- "just like DOLIST, but with one-dimensional arrays"
- (let ((index (gensym))
- (length (gensym))
- (vec (gensym)))
- `(let ((,vec ,vector))
- (declare (type vector ,vec))
- (do ((,index 0 (1+ ,index))
- (,length (length ,vec)))
- ((>= ,index ,length) ,result)
- (let ((,elt (aref ,vec ,index)))
- ,@forms)))))
-
-(defmacro dohash ((key-var value-var table &optional result) &body body)
- #!+sb-doc
- "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
- Iterate over the entries in a hash-table."
- (multiple-value-bind (forms decls) (parse-body body nil)
- (let ((gen (gensym))
- (n-more (gensym)))
- `(with-hash-table-iterator (,gen ,table)
- (loop
- (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
- ,@decls
- (unless ,n-more (return ,result))
- ,@forms))))))
-\f
-;;;; hash cache utility
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defvar *profile-hash-cache* nil))
-
-;;; a flag for whether it's too early in cold init to use caches so
-;;; that we have a better chance of recovering so that we have a
-;;; better chance of getting the system running so that we have a
-;;; better chance of diagnosing the problem which caused us to use the
-;;; caches too early
-#!+sb-show
-(defvar *hash-caches-initialized-p*)
-
-;;; Define a hash cache that associates some number of argument values
-;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
-;;; is used to compare the value for that arg in a cache entry with a
-;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
-;;; its first arg, but need not return any particular value.
-;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
-;;;
-;;; NAME is used to define these functions:
-;;; <name>-CACHE-LOOKUP Arg*
-;;; See whether there is an entry for the specified ARGs in the
-;;; cache. If not present, the :DEFAULT keyword (default NIL)
-;;; determines the result(s).
-;;; <name>-CACHE-ENTER Arg* Value*
-;;; Encache the association of the specified args with VALUE.
-;;; <name>-CACHE-CLEAR
-;;; Reinitialize the cache, invalidating all entries and allowing
-;;; the arguments and result values to be GC'd.
-;;;
-;;; These other keywords are defined:
-;;; :HASH-BITS <n>
-;;; The size of the cache as a power of 2.
-;;; :HASH-FUNCTION function
-;;; Some thing that can be placed in CAR position which will compute
-;;; a value between 0 and (1- (expt 2 <hash-bits>)).
-;;; :VALUES <n>
-;;; the number of return values cached for each function call
-;;; :INIT-WRAPPER <name>
-;;; The code for initializing the cache is wrapped in a form with
-;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
-;;; in type system definitions so that caches will be created
-;;; before top-level forms run.)
-(defmacro define-hash-cache (name args &key hash-function hash-bits default
- (init-wrapper 'progn)
- (values 1))
- (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
- (nargs (length args))
- (entry-size (+ nargs values))
- (size (ash 1 hash-bits))
- (total-size (* entry-size size))
- (default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (n-index (gensym))
- (n-cache (gensym)))
-
- (unless (= (length default-values) values)
- (error "The number of default values ~S differs from :VALUES ~D."
- default values))
-
- (collect ((inlines)
- (forms)
- (inits)
- (tests)
- (sets)
- (arg-vars)
- (values-indices)
- (values-names))
- (dotimes (i values)
- (values-indices `(+ ,n-index ,(+ nargs i)))
- (values-names (gensym)))
- (let ((n 0))
- (dolist (arg args)
- (unless (= (length arg) 2)
- (error "bad argument spec: ~S" arg))
- (let ((arg-name (first arg))
- (test (second arg)))
- (arg-vars arg-name)
- (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
- (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
- (incf n)))
-
- (when *profile-hash-cache*
- (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
- (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
- (inits `(setq ,n-probe 0))
- (inits `(setq ,n-miss 0))
- (forms `(defvar ,n-probe))
- (forms `(defvar ,n-miss))
- (forms `(declaim (fixnum ,n-miss ,n-probe)))))
-
- (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name ,(arg-vars)
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- (cond ((and ,@(tests))
- (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
- (values-indices))))
- (t
- ,@(when *profile-hash-cache*
- `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
- ,default))))))
-
- (let ((fun-name (symbolicate name "-CACHE-ENTER")))
- (inlines fun-name)
- (forms
- `(defun ,fun-name (,@(arg-vars) ,@(values-names))
- (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
- (,n-cache ,var-name))
- (declare (type fixnum ,n-index))
- ,@(sets)
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- (values-names))
- (values)))))
-
- (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
- (forms
- `(defun ,fun-name ()
- (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
- (,n-cache ,var-name))
- ((minusp ,n-index))
- (declare (type fixnum ,n-index))
- ,@(collect ((arg-sets))
- (dotimes (i nargs)
- (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
- (arg-sets))
- ,@(mapcar #'(lambda (i val)
- `(setf (svref ,n-cache ,i) ,val))
- (values-indices)
- default-values))
- (values)))
- (forms `(,fun-name)))
-
- (inits `(unless (boundp ',var-name)
- (setq ,var-name (make-array ,total-size))))
- #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
-
- `(progn
- (defvar ,var-name)
- (declaim (type (simple-vector ,total-size) ,var-name))
- #!-sb-fluid (declaim (inline ,@(inlines)))
- (,init-wrapper ,@(inits))
- ,@(forms)
- ',name))))
-
-;;; some syntactic sugar for defining a function whose values are
-;;; cached by DEFINE-HASH-CACHE
-(defmacro defun-cached ((name &rest options &key (values 1) default
- &allow-other-keys)
- args &body body-decls-doc)
- (let ((default-values (if (and (consp default) (eq (car default) 'values))
- (cdr default)
- (list default)))
- (arg-names (mapcar #'car args)))
- (collect ((values-names))
- (dotimes (i values)
- (values-names (gensym)))
- (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
- `(progn
- (define-hash-cache ,name ,args ,@options)
- (defun ,name ,arg-names
- ,@decls
- ,doc
- (cond #!+sb-show
- ((not (boundp '*hash-caches-initialized-p*))
- ;; This shouldn't happen, but it did happen to me
- ;; when revising the type system, and it's a lot
- ;; easier to figure out what what's going on with
- ;; that kind of problem if the system can be kept
- ;; alive until cold boot is complete. The recovery
- ;; mechanism should definitely be conditional on
- ;; some debugging feature (e.g. SB-SHOW) because
- ;; it's big, duplicating all the BODY code. -- WHN
- (/show0 ,name " too early in cold init, uncached")
- (/show0 ,(first arg-names) "=..")
- (/hexstr ,(first arg-names))
- ,@body)
- (t
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar (lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))))
-\f
-;;;; package idioms
-
-;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
-;;; instead of this function. (The distinction only actually matters when
-;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
-;;; you generally do want to signal an error instead of proceeding.)
-(defun %find-package-or-lose (package-designator)
- (or (find-package package-designator)
- (error 'sb!kernel:simple-package-error
- :package package-designator
- :format-control "The name ~S does not designate any package."
- :format-arguments (list package-designator))))
-
-;;; ANSI specifies (in the section for FIND-PACKAGE) that the
-;;; consequences of most operations on deleted packages are
-;;; unspecified. We try to signal errors in such cases.
-(defun find-undeleted-package-or-lose (package-designator)
- (let ((maybe-result (%find-package-or-lose package-designator)))
- (if (package-name maybe-result) ; if not deleted
- maybe-result
- (error 'sb!kernel:simple-package-error
- :package maybe-result
- :format-control "The package ~S has been deleted."
- :format-arguments (list maybe-result)))))
-\f
-;;;; miscellany
-
-;;; Is NAME a legal function name?
-(defun legal-function-name-p (name)
- (or (symbolp name)
- (and (consp name)
- (eq (car name) 'setf)
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
-
-;;; Given a function name, return the name for the BLOCK which
-;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
-(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
-(defun function-name-block-name (function-name)
- (cond ((symbolp function-name)
- function-name)
- ((and (consp function-name)
- (= (length function-name) 2)
- (eq (first function-name) 'setf))
- (second function-name))
- (t
- (error "not legal as a function name: ~S" function-name))))
-
-;;; Is X a (possibly-improper) list of at least N elements?
-(declaim (ftype (function (t index)) list-of-length-at-least-p))
-(defun list-of-length-at-least-p (x n)
- (or (zerop n) ; since anything can be considered an improper list of length 0
- (and (consp x)
- (list-of-length-at-least-p (cdr x) (1- n)))))
-
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
-;;; ANSI guarantees that some symbols are self-evaluating. This
-;;; function is to be called just before a change which would affect
-;;; that. (We don't absolutely have to call this function before such
-;;; changes, since such changes are given as undefined behavior. In
-;;; particular, we don't if the runtime cost would be annoying. But
-;;; otherwise it's nice to do so.)
-(defun about-to-modify (symbol)
- (declare (type symbol symbol))
- (cond ((eq symbol t)
- (error "Veritas aeterna. (can't change T)"))
- ((eq symbol nil)
- (error "Nihil ex nihil. (can't change NIL)"))
- ((keywordp symbol)
- (error "Keyword values can't be changed."))
- ;; (Just because a value is CONSTANTP is not a good enough
- ;; reason to complain here, because we want DEFCONSTANT to
- ;; be able to use this function, and it's legal to DEFCONSTANT
- ;; a constant as long as the new value is EQL to the old
- ;; value.)
- ))
-
-;;; Return a function like FUN, but expecting its (two) arguments in
-;;; the opposite order that FUN does.
-(declaim (inline swapped-args-fun))
-(defun swapped-args-fun (fun)
- (declare (type function fun))
- (lambda (x y)
- (funcall fun y x)))
-
-;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
-;;;
-;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
-;;; The CL:ASSERT restarts and whatnot expand into a significant
-;;; amount of code when you multiply them by 400, so replacing them
-;;; with this should reduce the size of the system by enough to be
-;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
-;;; worthwhile, and since I don't really like CERROR stuff deep in the
-;;; guts of complex systems anyway, I replaced it too.)
-(defmacro aver (expr)
- `(unless ,expr
- (%failed-aver ,(let ((*package* (find-package :keyword)))
- (format nil "~S" expr)))))
-(defun %failed-aver (expr-as-string)
- (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
-(defmacro enforce-type (value type)
- (once-only ((value value))
- `(unless (typep ,value ',type)
- (%failed-aver-type ,value ',type))))
-(defun %failed-enforce-type (value type)
- (error 'simple-type-error
- :value value
- :expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
- :format-arguments (list value type)))
-
-;;; Return the numeric value of a type bound, i.e. an interval bound
-;;; more or less in the format of bounds in ANSI's type specifiers,
-;;; where a bare numeric value is a closed bound and a list of a
-;;; single numeric value is an open bound.
-;;;
-;;; The "more or less" bit is that the no-bound-at-all case is
-;;; represented by NIL (not by * as in ANSI type specifiers); and in
-;;; this case we return NIL.
-(defun type-bound-number (x)
- (if (consp x)
- (destructuring-bind (result) x result)
- x))
-
-;;; some commonly-occuring CONSTANTLY forms
-(macrolet ((def-constantly-fun (name constant-expr)
- `(setf (symbol-function ',name)
- (constantly ,constant-expr))))
- (def-constantly-fun constantly-t t)
- (def-constantly-fun constantly-nil nil)
- (def-constantly-fun constantly-0 0))
-\f
-;;;; utilities for two-VALUES predicates
-
-;;; sort of like ANY and EVERY, except:
-;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
-;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
-;;; as SUBTYPEP does.)
-;;; * THING is just an atom, and we apply OP (an arity-2 function)
-;;; successively to THING and each element of LIST.
-(defun any/type (op thing list)
- (declare (type function op))
- (let ((certain? t))
- (dolist (i list (values nil certain?))
- (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (when sub-value (return (values t t)))
- (setf certain? nil))))))
-(defun every/type (op thing list)
- (declare (type function op))
- (let ((certain? t))
- (dolist (i list (if certain? (values t t) (values nil nil)))
- (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
- (if sub-certain?
- (unless sub-value (return (values nil t)))
- (setf certain? nil))))))
-\f
-;;;; DEFPRINTER
-
-;;; These functions are called by the expansion of the DEFPRINTER
-;;; macro to do the actual printing.
-(declaim (ftype (function (symbol t stream) (values))
- defprinter-prin1 defprinter-princ))
-(defun defprinter-prin1 (name value stream)
- (defprinter-prinx #'prin1 name value stream))
-(defun defprinter-princ (name value stream)
- (defprinter-prinx #'princ name value stream))
-(defun defprinter-prinx (prinx name value stream)
- (declare (type function prinx))
- (when *print-pretty*
- (pprint-newline :linear stream))
- (format stream ":~A " name)
- (funcall prinx value stream)
- (values))
-(defun defprinter-print-space (stream)
- (write-char #\space stream))
-
-;;; Define some kind of reasonable PRINT-OBJECT method for a
-;;; STRUCTURE-OBJECT class.
-;;;
-;;; NAME is the name of the structure class, and CONC-NAME is the same
-;;; as in DEFSTRUCT.
-;;;
-;;; The SLOT-DESCS describe how each slot should be printed. Each
-;;; SLOT-DESC can be a slot name, indicating that the slot should
-;;; simply be printed. A SLOT-DESC may also be a list of a slot name
-;;; and other stuff. The other stuff is composed of keywords followed
-;;; by expressions. The expressions are evaluated with the variable
-;;; which is the slot name bound to the value of the slot. These
-;;; keywords are defined:
-;;;
-;;; :PRIN1 Print the value of the expression instead of the slot value.
-;;; :PRINC Like :PRIN1, only PRINC the value
-;;; :TEST Only print something if the test is true.
-;;;
-;;; If no printing thing is specified then the slot value is printed
-;;; as if by PRIN1.
-;;;
-;;; The structure being printed is bound to STRUCTURE and the stream
-;;; is bound to STREAM.
-(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
- (symbol-name name)
- "-")))
- &rest slot-descs)
- (let ((first? t)
- maybe-print-space
- (reversed-prints nil)
- (stream (gensym "STREAM")))
- (flet ((sref (slot-name)
- `(,(symbolicate conc-name slot-name) structure)))
- (dolist (slot-desc slot-descs)
- (if first?
- (setf maybe-print-space nil
- first? nil)
- (setf maybe-print-space `(defprinter-print-space ,stream)))
- (cond ((atom slot-desc)
- (push maybe-print-space reversed-prints)
- (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
- reversed-prints))
- (t
- (let ((sname (first slot-desc))
- (test t))
- (collect ((stuff))
- (do ((option (rest slot-desc) (cddr option)))
- ((null option)
- (push `(let ((,sname ,(sref sname)))
- (when ,test
- ,maybe-print-space
- ,@(or (stuff)
- `((defprinter-prin1
- ',sname ,sname ,stream)))))
- reversed-prints))
- (case (first option)
- (:prin1
- (stuff `(defprinter-prin1
- ',sname ,(second option) ,stream)))
- (:princ
- (stuff `(defprinter-princ
- ',sname ,(second option) ,stream)))
- (:test (setq test (second option)))
- (t
- (error "bad option: ~S" (first option)))))))))))
- `(def!method print-object ((structure ,name) ,stream)
- ;; FIXME: should probably be byte-compiled
- (pprint-logical-block (,stream nil)
- (print-unreadable-object (structure ,stream :type t)
- ,@(nreverse reversed-prints))))))
-\f
-#|
-;;; REMOVEME when done testing byte cross-compiler
-(defun byte-compiled-foo (x y)
- (declare (optimize (speed 0) (debug 1)))
- (if x
- x
- (cons y y)))
-|#
--- /dev/null
+;;;; various extensions (including SB-INT "internal extensions")
+;;;; available both in the cross-compilation host Lisp and in the
+;;;; target SBCL
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+;;; something not EQ to anything we might legitimately READ
+(defparameter *eof-object* (make-symbol "EOF-OBJECT"))
+
+;;; a type used for indexing into arrays, and for related quantities
+;;; like lengths of lists
+;;;
+;;; It's intentionally limited to one less than the
+;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
+;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
+;;; that lets the system know it can increment a value of this type
+;;; without having to worry about using a bignum to represent the
+;;; result.
+;;;
+;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
+;;; bound because ANSI specifies it as an exclusive bound.)
+(def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
+
+;;; the default value used for initializing character data. The ANSI
+;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
+;;; because it's not in the ANSI table of portable characters.
+(defconstant default-init-char #\space)
+
+;;; CHAR-CODE values for ASCII characters which we care about but
+;;; which aren't defined in section "2.1.3 Standard Characters" of the
+;;; ANSI specification for Lisp
+;;;
+;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
+;;; FOO-CHAR-CODE). I suspect that the current implementation is
+;;; expanding this idiom into a full call to CODE-CHAR, which is an
+;;; annoying overhead. I should check whether this is happening, and
+;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
+;;; (or just find a nicer way of expressing characters portably?) --
+;;; WHN 19990713
+(defconstant bell-char-code 7)
+(defconstant tab-char-code 9)
+(defconstant form-feed-char-code 12)
+(defconstant return-char-code 13)
+(defconstant escape-char-code 27)
+(defconstant rubout-char-code 127)
+\f
+;;;; type-ish predicates
+
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; FIXME: This implementation will hang on circular list structure.
+;;; Since this is an error-checking utility, i.e. its job is to deal
+;;; with screwed-up input, it'd be good style to fix it so that it can
+;;; deal with circular list structure.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Return true if X is a proper list whose length is between MIN and
+ ;; MAX (inclusive).
+ (defun proper-list-of-length-p (x min &optional (max min))
+ (cond ((minusp max)
+ nil)
+ ((null x)
+ (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil))))
+
+;;; Is X a circular list?
+(defun circular-list-p (x)
+ (and (listp x)
+ (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
+ (do ((y x (safe-cddr y))
+ (started-p nil t)
+ (z x (cdr z)))
+ ((or (not z) (not y)) nil)
+ (when (and started-p (eq y z))
+ (return t))))))
+
+;;; Is X a (possibly-improper) list of at least N elements?
+(declaim (ftype (function (t index)) list-of-length-at-least-p))
+(defun list-of-length-at-least-p (x n)
+ (or (zerop n) ; since anything can be considered an improper list of length 0
+ (and (consp x)
+ (list-of-length-at-least-p (cdr x) (1- n)))))
+\f
+;;;; the COLLECT macro
+;;;;
+;;;; comment from CMU CL: "the ultimate collection macro..."
+
+;;; helper functions for COLLECT, which become the expanders of the
+;;; MACROLET definitions created by COLLECT
+;;;
+;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
+;;;
+;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
+;;; is the pointer to the current tail of the list, or NIL if the list
+;;; is empty.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun collect-normal-expander (n-value fun forms)
+ `(progn
+ ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
+ ,n-value))
+ (defun collect-list-expander (n-value n-tail forms)
+ (let ((n-res (gensym)))
+ `(progn
+ ,@(mapcar (lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value))))
+
+;;; Collect some values somehow. Each of the collections specifies a
+;;; bunch of things which collected during the evaluation of the body
+;;; of the form. The name of the collection is used to define a local
+;;; macro, a la MACROLET. Within the body, this macro will evaluate
+;;; each of its arguments and collect the result, returning the
+;;; current value after the collection is done. The body is evaluated
+;;; as a PROGN; to get the final values when you are done, just call
+;;; the collection macro with no arguments.
+;;;
+;;; INITIAL-VALUE is the value that the collection starts out with,
+;;; which defaults to NIL. FUNCTION is the function which does the
+;;; collection. It is a function which will accept two arguments: the
+;;; value to be collected and the current collection. The result of
+;;; the function is made the new value for the collection. As a
+;;; totally magical special-case, FUNCTION may be COLLECT, which tells
+;;; us to build a list in forward order; this is the default. If an
+;;; INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd
+;;; onto the end. Note that FUNCTION may be anything that can appear
+;;; in the functional position, including macros and lambdas.
+(defmacro collect (collections &body body)
+ (let ((macros ())
+ (binds ()))
+ (dolist (spec collections)
+ (unless (proper-list-of-length-p spec 1 3)
+ (error "malformed collection specifier: ~S." spec))
+ (let* ((name (first spec))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
+ `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+\f
+;;;; some old-fashioned functions. (They're not just for old-fashioned
+;;;; code, they're also used as optimized forms of the corresponding
+;;;; general functions when the compiler can prove that they're
+;;;; equivalent.)
+
+;;; like (MEMBER ITEM LIST :TEST #'EQ)
+(defun memq (item list)
+ #!+sb-doc
+ "Returns tail of LIST beginning with first element EQ to ITEM."
+ ;; KLUDGE: These could be and probably should be defined as
+ ;; (MEMBER ITEM LIST :TEST #'EQ)),
+ ;; but when I try to cross-compile that, I get an error from
+ ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
+ ;; comments for that error say it "is probably a botched interpreter stub".
+ ;; Rather than try to figure that out, I just rewrote this function from
+ ;; scratch. -- WHN 19990512
+ (do ((i list (cdr i)))
+ ((null i))
+ (when (eq (car i) item)
+ (return i))))
+
+;;; like (ASSOC ITEM ALIST :TEST #'EQ):
+;;; Return the first pair of ALIST where ITEM is EQ to the key of
+;;; the pair.
+(defun assq (item alist)
+ ;; KLUDGE: CMU CL defined this with
+ ;; (DECLARE (INLINE ASSOC))
+ ;; (ASSOC ITEM ALIST :TEST #'EQ))
+ ;; which is pretty, but which would have required adding awkward
+ ;; build order constraints on SBCL (or figuring out some way to make
+ ;; inline definitions installable at build-the-cross-compiler time,
+ ;; which was too ambitious for now). Rather than mess with that, we
+ ;; just define ASSQ explicitly in terms of more primitive
+ ;; operations:
+ (dolist (pair alist)
+ (when (eq (car pair) item)
+ (return pair))))
+
+;;; like (DELETE .. :TEST #'EQ):
+;;; Delete all LIST entries EQ to ITEM (destructively modifying
+;;; LIST), and return the modified LIST.
+(defun delq (item list)
+ (let ((list list))
+ (do ((x list (cdr x))
+ (splice '()))
+ ((endp x) list)
+ (cond ((eq item (car x))
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))) ; Move splice along to include element.
+
+
+;;; like (POSITION .. :TEST #'EQ):
+;;; Return the position of the first element EQ to ITEM.
+(defun posq (item list)
+ (do ((i list (cdr i))
+ (j 0 (1+ j)))
+ ((null i))
+ (when (eq (car i) item)
+ (return j))))
+
+(declaim (inline neq))
+(defun neq (x y)
+ (not (eq x y)))
+\f
+;;;; miscellaneous iteration extensions
+
+;;; "the ultimate iteration macro"
+;;;
+;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+(defmacro named-let (name binds &body body)
+ #!+sb-doc
+ (dolist (x binds)
+ (unless (proper-list-of-length-p x 2)
+ (error "malformed NAMED-LET variable spec: ~S" x)))
+ `(labels ((,name ,(mapcar #'first binds) ,@body))
+ (,name ,@(mapcar #'second binds))))
+
+;;; just like DOLIST, but with one-dimensional arrays
+(defmacro dovector ((elt vector &optional result) &rest forms)
+ (let ((index (gensym))
+ (length (gensym))
+ (vec (gensym)))
+ `(let ((,vec ,vector))
+ (declare (type vector ,vec))
+ (do ((,index 0 (1+ ,index))
+ (,length (length ,vec)))
+ ((>= ,index ,length) ,result)
+ (let ((,elt (aref ,vec ,index)))
+ ,@forms)))))
+
+;;; Iterate over the entries in a HASH-TABLE.
+(defmacro dohash ((key-var value-var table &optional result) &body body)
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (let ((gen (gensym))
+ (n-more (gensym)))
+ `(with-hash-table-iterator (,gen ,table)
+ (loop
+ (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
+ ,@decls
+ (unless ,n-more (return ,result))
+ ,@forms))))))
+\f
+;;;; hash cache utility
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *profile-hash-cache* nil))
+
+;;; a flag for whether it's too early in cold init to use caches so
+;;; that we have a better chance of recovering so that we have a
+;;; better chance of getting the system running so that we have a
+;;; better chance of diagnosing the problem which caused us to use the
+;;; caches too early
+#!+sb-show
+(defvar *hash-caches-initialized-p*)
+
+;;; Define a hash cache that associates some number of argument values
+;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
+;;; is used to compare the value for that arg in a cache entry with a
+;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
+;;; its first arg, but need not return any particular value.
+;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
+;;;
+;;; NAME is used to define these functions:
+;;; <name>-CACHE-LOOKUP Arg*
+;;; See whether there is an entry for the specified ARGs in the
+;;; cache. If not present, the :DEFAULT keyword (default NIL)
+;;; determines the result(s).
+;;; <name>-CACHE-ENTER Arg* Value*
+;;; Encache the association of the specified args with VALUE.
+;;; <name>-CACHE-CLEAR
+;;; Reinitialize the cache, invalidating all entries and allowing
+;;; the arguments and result values to be GC'd.
+;;;
+;;; These other keywords are defined:
+;;; :HASH-BITS <n>
+;;; The size of the cache as a power of 2.
+;;; :HASH-FUNCTION function
+;;; Some thing that can be placed in CAR position which will compute
+;;; a value between 0 and (1- (expt 2 <hash-bits>)).
+;;; :VALUES <n>
+;;; the number of return values cached for each function call
+;;; :INIT-WRAPPER <name>
+;;; The code for initializing the cache is wrapped in a form with
+;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
+;;; in type system definitions so that caches will be created
+;;; before top-level forms run.)
+(defmacro define-hash-cache (name args &key hash-function hash-bits default
+ (init-wrapper 'progn)
+ (values 1))
+ (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+ (nargs (length args))
+ (entry-size (+ nargs values))
+ (size (ash 1 hash-bits))
+ (total-size (* entry-size size))
+ (default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (n-index (gensym))
+ (n-cache (gensym)))
+
+ (unless (= (length default-values) values)
+ (error "The number of default values ~S differs from :VALUES ~D."
+ default values))
+
+ (collect ((inlines)
+ (forms)
+ (inits)
+ (tests)
+ (sets)
+ (arg-vars)
+ (values-indices)
+ (values-names))
+ (dotimes (i values)
+ (values-indices `(+ ,n-index ,(+ nargs i)))
+ (values-names (gensym)))
+ (let ((n 0))
+ (dolist (arg args)
+ (unless (= (length arg) 2)
+ (error "bad argument spec: ~S" arg))
+ (let ((arg-name (first arg))
+ (test (second arg)))
+ (arg-vars arg-name)
+ (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
+ (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
+ (incf n)))
+
+ (when *profile-hash-cache*
+ (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
+ (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
+ (inits `(setq ,n-probe 0))
+ (inits `(setq ,n-miss 0))
+ (forms `(defvar ,n-probe))
+ (forms `(defvar ,n-miss))
+ (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name ,(arg-vars)
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ (cond ((and ,@(tests))
+ (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
+ (values-indices))))
+ (t
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
+ ,default))))))
+
+ (let ((fun-name (symbolicate name "-CACHE-ENTER")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name (,@(arg-vars) ,@(values-names))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ ,@(sets)
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ (values-names))
+ (values)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
+ (forms
+ `(defun ,fun-name ()
+ (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
+ (,n-cache ,var-name))
+ ((minusp ,n-index))
+ (declare (type fixnum ,n-index))
+ ,@(collect ((arg-sets))
+ (dotimes (i nargs)
+ (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
+ (arg-sets))
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ default-values))
+ (values)))
+ (forms `(,fun-name)))
+
+ (inits `(unless (boundp ',var-name)
+ (setq ,var-name (make-array ,total-size))))
+ #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
+
+ `(progn
+ (defvar ,var-name)
+ (declaim (type (simple-vector ,total-size) ,var-name))
+ #!-sb-fluid (declaim (inline ,@(inlines)))
+ (,init-wrapper ,@(inits))
+ ,@(forms)
+ ',name))))
+
+;;; some syntactic sugar for defining a function whose values are
+;;; cached by DEFINE-HASH-CACHE
+(defmacro defun-cached ((name &rest options &key (values 1) default
+ &allow-other-keys)
+ args &body body-decls-doc)
+ (let ((default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (arg-names (mapcar #'car args)))
+ (collect ((values-names))
+ (dotimes (i values)
+ (values-names (gensym)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on
+ ;; some debugging feature (e.g. SB-SHOW) because
+ ;; it's big, duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,(values-names)
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ (values-names) default-values))
+ (multiple-value-bind ,(values-names)
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@(values-names))
+ (values ,@(values-names)))
+ (values ,@(values-names))))))))))))
+\f
+;;;; package idioms
+
+;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
+;;; instead of this function. (The distinction only actually matters when
+;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
+;;; you generally do want to signal an error instead of proceeding.)
+(defun %find-package-or-lose (package-designator)
+ (or (find-package package-designator)
+ (error 'sb!kernel:simple-package-error
+ :package package-designator
+ :format-control "The name ~S does not designate any package."
+ :format-arguments (list package-designator))))
+
+;;; ANSI specifies (in the section for FIND-PACKAGE) that the
+;;; consequences of most operations on deleted packages are
+;;; unspecified. We try to signal errors in such cases.
+(defun find-undeleted-package-or-lose (package-designator)
+ (let ((maybe-result (%find-package-or-lose package-designator)))
+ (if (package-name maybe-result) ; if not deleted
+ maybe-result
+ (error 'sb!kernel:simple-package-error
+ :package maybe-result
+ :format-control "The package ~S has been deleted."
+ :format-arguments (list maybe-result)))))
+\f
+;;;; various operations on names
+
+;;; Is NAME a legal function name?
+(defun legal-function-name-p (name)
+ (or (symbolp name)
+ (and (consp name)
+ (eq (car name) 'setf)
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (null (cddr name)))))
+
+;;; Given a function name, return the name for the BLOCK which
+;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
+(defun function-name-block-name (function-name)
+ (cond ((symbolp function-name)
+ function-name)
+ ((and (consp function-name)
+ (= (length function-name) 2)
+ (eq (first function-name) 'setf))
+ (second function-name))
+ (t
+ (error "not legal as a function name: ~S" function-name))))
+
+;;; ANSI guarantees that some symbols are self-evaluating. This
+;;; function is to be called just before a change which would affect
+;;; that. (We don't absolutely have to call this function before such
+;;; changes, since such changes are given as undefined behavior. In
+;;; particular, we don't if the runtime cost would be annoying. But
+;;; otherwise it's nice to do so.)
+(defun about-to-modify (symbol)
+ (declare (type symbol symbol))
+ (cond ((eq symbol t)
+ (error "Veritas aeterna. (can't change T)"))
+ ((eq symbol nil)
+ (error "Nihil ex nihil. (can't change NIL)"))
+ ((keywordp symbol)
+ (error "Keyword values can't be changed."))
+ ;; (Just because a value is CONSTANTP is not a good enough
+ ;; reason to complain here, because we want DEFCONSTANT to
+ ;; be able to use this function, and it's legal to DEFCONSTANT
+ ;; a constant as long as the new value is EQL to the old
+ ;; value.)
+ ))
+\f
+;;;; ONCE-ONLY
+;;;;
+;;;; "The macro ONCE-ONLY has been around for a long time on various
+;;;; systems [..] if you can understand how to write and when to use
+;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
+;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
+;;;; in Common Lisp_, p. 853
+
+;;; ONCE-ONLY is a utility useful in writing source transforms and
+;;; macros. It provides a concise way to wrap a LET around some code
+;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.
+(defmacro once-only (specs &body body)
+ (named-let frob ((specs specs)
+ (body body))
+ (if (null specs)
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym (symbol-name name))))
+ `(let ((,exp-temp ,(second spec))
+ (,name (gensym "ONCE-ONLY-")))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
+\f
+;;;; various error-checking utilities
+
+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.
+(declaim (ftype (function () nil) required-argument))
+(defun required-argument ()
+ #!+sb-doc
+ (/show0 "entering REQUIRED-ARGUMENT")
+ (error "A required &KEY argument was not supplied."))
+
+;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
+;;;
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
+;;; The CL:ASSERT restarts and whatnot expand into a significant
+;;; amount of code when you multiply them by 400, so replacing them
+;;; with this should reduce the size of the system by enough to be
+;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
+;;; worthwhile, and since I don't really like CERROR stuff deep in the
+;;; guts of complex systems anyway, I replaced it too.)
+(defmacro aver (expr)
+ `(unless ,expr
+ (%failed-aver ,(let ((*package* (find-package :keyword)))
+ (format nil "~S" expr)))))
+(defun %failed-aver (expr-as-string)
+ (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+(defmacro enforce-type (value type)
+ (once-only ((value value))
+ `(unless (typep ,value ',type)
+ (%failed-aver-type ,value ',type))))
+(defun %failed-enforce-type (value type)
+ (error 'simple-type-error
+ :value value
+ :expected-type type
+ :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-arguments (list value type)))
+\f
+;;; Return a list of N gensyms. (This is a common suboperation in
+;;; macros and other code-manipulating code.)
+(declaim (ftype (function (index) list) make-gensym-list))
+(defun make-gensym-list (n)
+ (loop repeat n collect (gensym)))
+
+;;; Return a function like FUN, but expecting its (two) arguments in
+;;; the opposite order that FUN does.
+(declaim (inline swapped-args-fun))
+(defun swapped-args-fun (fun)
+ (declare (type function fun))
+ (lambda (x y)
+ (funcall fun y x)))
+
+;;; Return the numeric value of a type bound, i.e. an interval bound
+;;; more or less in the format of bounds in ANSI's type specifiers,
+;;; where a bare numeric value is a closed bound and a list of a
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+ (if (consp x)
+ (destructuring-bind (result) x result)
+ x))
+
+;;; some commonly-occuring CONSTANTLY forms
+(macrolet ((def-constantly-fun (name constant-expr)
+ `(setf (symbol-function ',name)
+ (constantly ,constant-expr))))
+ (def-constantly-fun constantly-t t)
+ (def-constantly-fun constantly-nil nil)
+ (def-constantly-fun constantly-0 0))
+
+;;; If X is an atom, see whether it is present in *FEATURES*. Also
+;;; handle arbitrary combinations of atoms using NOT, AND, OR.
+(defun featurep (x)
+ (if (consp x)
+ (case (car x)
+ ((:not not)
+ (if (cddr x)
+ (error "too many subexpressions in feature expression: ~S" x)
+ (not (featurep (cadr x)))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x)))
+ (not (null (memq x *features*)))))
+
+;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
+;;; &KEY-argument-list-style list of alternating keywords and
+;;; arbitrary values, return a new &KEY-argument-list-style list with
+;;; all substitutions applied to it.
+;;;
+;;; Note: If efficiency mattered, we could do less consing. (But if
+;;; efficiency mattered, why would we be using &KEY arguments at
+;;; all, much less renaming &KEY arguments?)
+;;;
+;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
+(defun rename-key-args (rename-list key-args)
+ (declare (type list rename-list key-args))
+ ;; Walk through RENAME-LIST modifying RESULT as per each element in
+ ;; RENAME-LIST.
+ (do ((result (copy-list key-args))) ; may be modified below
+ ((null rename-list) result)
+ (destructuring-bind (old new) (pop rename-list)
+ ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
+ (declare (type symbol old new))
+ ;; Walk through RESULT renaming any OLD key argument to NEW.
+ (do ((in-result result (cddr in-result)))
+ ((null in-result))
+ (declare (type list in-result))
+ (when (eq (car in-result) old)
+ (setf (car in-result) new))))))
+
+;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
+;;; other ANSI input functions, is defined to communicate end of file
+;;; status with its return value, not by signalling. That is not the
+;;; behavior that we usually want. This function is a wrapper which
+;;; restores the behavior that we usually want, causing READ-SEQUENCE
+;;; to communicate end-of-file status by signalling.
+(defun read-sequence-or-die (sequence stream &key start end)
+ ;; implementation using READ-SEQUENCE
+ #-no-ansi-read-sequence
+ (let ((read-end (read-sequence sequence
+ stream
+ :start start
+ :end end)))
+ (unless (= read-end end)
+ (error 'end-of-file :stream stream))
+ (values))
+ ;; workaround for broken READ-SEQUENCE
+ #+no-ansi-read-sequence
+ (progn
+ (aver (<= start end))
+ (let ((etype (stream-element-type stream)))
+ (cond ((equal etype '(unsigned-byte 8))
+ (do ((i start (1+ i)))
+ ((>= i end)
+ (values))
+ (setf (aref sequence i)
+ (read-byte stream))))
+ (t (error "unsupported element type ~S" etype))))))
+\f
+;;;; utilities for two-VALUES predicates
+
+;;; sort of like ANY and EVERY, except:
+;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
+;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
+;;; as SUBTYPEP does.)
+;;; * THING is just an atom, and we apply OP (an arity-2 function)
+;;; successively to THING and each element of LIST.
+(defun any/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (values nil certain?))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (when sub-value (return (values t t)))
+ (setf certain? nil))))))
+(defun every/type (op thing list)
+ (declare (type function op))
+ (let ((certain? t))
+ (dolist (i list (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
+ (if sub-certain?
+ (unless sub-value (return (values nil t)))
+ (setf certain? nil))))))
+\f
+;;;; DEFPRINTER
+
+;;; These functions are called by the expansion of the DEFPRINTER
+;;; macro to do the actual printing.
+(declaim (ftype (function (symbol t stream) (values))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream)
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream)
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+(defun defprinter-print-space (stream)
+ (write-char #\space stream))
+
+;;; Define some kind of reasonable PRINT-OBJECT method for a
+;;; STRUCTURE-OBJECT class.
+;;;
+;;; NAME is the name of the structure class, and CONC-NAME is the same
+;;; as in DEFSTRUCT.
+;;;
+;;; The SLOT-DESCS describe how each slot should be printed. Each
+;;; SLOT-DESC can be a slot name, indicating that the slot should
+;;; simply be printed. A SLOT-DESC may also be a list of a slot name
+;;; and other stuff. The other stuff is composed of keywords followed
+;;; by expressions. The expressions are evaluated with the variable
+;;; which is the slot name bound to the value of the slot. These
+;;; keywords are defined:
+;;;
+;;; :PRIN1 Print the value of the expression instead of the slot value.
+;;; :PRINC Like :PRIN1, only PRINC the value
+;;; :TEST Only print something if the test is true.
+;;;
+;;; If no printing thing is specified then the slot value is printed
+;;; as if by PRIN1.
+;;;
+;;; The structure being printed is bound to STRUCTURE and the stream
+;;; is bound to STREAM.
+(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-")))
+ &rest slot-descs)
+ (let ((first? t)
+ maybe-print-space
+ (reversed-prints nil)
+ (stream (gensym "STREAM")))
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (dolist (slot-desc slot-descs)
+ (if first?
+ (setf maybe-print-space nil
+ first? nil)
+ (setf maybe-print-space `(defprinter-print-space ,stream)))
+ (cond ((atom slot-desc)
+ (push maybe-print-space reversed-prints)
+ (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
+ reversed-prints))
+ (t
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (push `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,maybe-print-space
+ ,@(or (stuff)
+ `((defprinter-prin1
+ ',sname ,sname ,stream)))))
+ reversed-prints))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1
+ ',sname ,(second option) ,stream)))
+ (:princ
+ (stuff `(defprinter-princ
+ ',sname ,(second option) ,stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad option: ~S" (first option)))))))))))
+ `(def!method print-object ((structure ,name) ,stream)
+ ;; FIXME: should probably be byte-compiled
+ (pprint-logical-block (,stream nil)
+ (print-unreadable-object (structure ,stream :type t)
+ ,@(nreverse reversed-prints))))))
+\f
+#|
+;;; REMOVEME when done testing byte cross-compiler
+(defun byte-compiled-foo (x y)
+ (declare (optimize (speed 0) (debug 1)))
+ (if x
+ x
+ (cons y y)))
+|#
;;; Signal the appropriate condition when we get a floating-point error.
(defun sigfpe-handler (signal info context)
- (declare (ignore signal info))
- (declare (ignore context)) ; stub!
+ (declare (ignore signal info context))
(declare (type system-area-pointer context))
;; FIXME: The find-the-detailed-problem code below went stale with
;; the big switchover to POSIX signal handling and signal contexts
(defun ,lisp-fun ()
(sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
+#!+(or cgc gencgc) (progn
#!-sb-fluid (declaim (inline dynamic-usage))
-(def-c-var-frob dynamic-usage "bytes_allocated")
+(def-c-var-frob dynamic-usage "bytes_allocated"))
+
+#!-(or cgc gencgc)
+(defun dynamic-usage ()
+ (the (unsigned-byte 32)
+ (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
+ (current-dynamic-space-start))))
+
+#!-gencgc (progn
+#!-sb-fluid (declaim (inline current-dynamic-space-start))
+(def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
(defun static-space-usage ()
(- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
(finish-output notify-stream))
(defparameter *gc-notify-after* #'default-gc-notify-after
#!+sb-doc
- "The function bound to this variable is invoked after GC'ing (unless
- *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
- the amount of dynamic usage (in bytes) now free, the number of
- bytes freed by the GC, and the new GC trigger threshold. The function
- should notify the user that the system has finished GC'ing.")
+ "The function bound to this variable is invoked after GC'ing with
+the value of *GC-NOTIFY-STREAM*, the amount of dynamic usage (in
+bytes) now free, the number of bytes freed by the GC, and the new GC
+trigger threshold. The function should notify the user that the system
+has finished GC'ing.")
\f
;;;; internal GC
(sb!alien:def-alien-routine collect-garbage sb!c-call:int
#!+gencgc (last-gen sb!c-call:int))
+
(sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
(dynamic-usage sb!c-call:unsigned-long))
;;;
;;; For GENCGC all generations < GEN will be GC'ed.
;;;
-(defun sub-gc (&key force-p #!+gencgc (gen 0))
+(defun sub-gc (&key force-p (gen 0))
(/show0 "entering SUB-GC")
(unless *already-maybe-gcing*
- (/show0 "not *ALREADY-MAYBE-GCING*")
(let* ((*already-maybe-gcing* t)
(start-time (get-internal-run-time))
(pre-gc-dyn-usage (dynamic-usage))
default-bytes-consed-between-gcs)
(setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
(when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
- (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
(setf *need-to-collect-garbage* t))
(when (or force-p
(and *need-to-collect-garbage* (not *gc-inhibit*)))
- (/show0 "Evidently we ought to collect garbage..")
(when (and (not force-p)
*gc-inhibit-hook*
(carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
- (/show0 "..but we're inhibited.")
(setf *gc-inhibit* t)
(return-from sub-gc nil))
;; KLUDGE: Wow, we really mask interrupts all the time we're
;; calls to user-settable GC hook functions.
(let ((*standard-output* *terminal-io*))
(when *gc-notify-stream*
- (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
(if (streamp *gc-notify-stream*)
(carefully-funcall *gc-notify-before*
*gc-notify-stream*
(warn
"*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
(dolist (hook *before-gc-hooks*)
- (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
(carefully-funcall hook))
(when *gc-trigger*
(clear-auto-gc-trigger))
- (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
#!-gencgc (funcall *internal-gc*)
;; FIXME: This EQ test is pretty gross. Among its other
;; nastinesses, it looks as though it could break if we
#!+gencgc (if (eq *internal-gc* #'collect-garbage)
(funcall *internal-gc* gen)
(funcall *internal-gc*))
- (/show0 "back from FUNCALL to *INTERNAL-GC*")
(let* ((post-gc-dyn-usage (dynamic-usage))
(bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
(/show0 "got (DYNAMIC-USAGE) and BYTES-FREED")
;; e.g. 108% of total memory usage.
(carefully-funcall hook))
(when *gc-notify-stream*
- (/show0 "doing the *GC-NOTIFY-AFTER* thing")
(if (streamp *gc-notify-stream*)
(carefully-funcall *gc-notify-after*
*gc-notify-stream*
*gc-trigger*)
(warn
"*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
- (/show0 "scrubbing control stack")
- (scrub-control-stack)))
- (/show0 "updating *GC-RUN-TIME*")
+ (scrub-control-stack))) ;XXX again? we did this from C ...
(incf *gc-run-time* (- (get-internal-run-time)
start-time))))
;; FIXME: should probably return (VALUES), here and in RETURN-FROM
- (/show0 "returning from tail of SUB-GC")
nil)
;;; This routine is called by the allocation miscops to decide whether
object)
;;; This is the user-advertised garbage collection function.
-;;;
-;;; KLUDGE: GC shouldn't have different parameters depending on what
-;;; garbage collector we use. -- WHN 19991020
-#!-gencgc
-(defun gc ()
- #!+sb-doc
- "Initiates a garbage collection."
- (sub-gc :force-p t))
-#!+gencgc
-(defun gc (&key (gen 0) (full nil))
- #!+sb-doc
- "Initiates a garbage collection.
- GEN controls the number of generations to garbage collect."
- ;; FIXME: The bare 6 here (corresponding to a bare 6 in
- ;; the gencgc.c sources) is nasty.
+
+(defun gc (&key (gen 0) (full nil) &allow-other-keys)
+ #!+(and sb-doc gencgc)
+ "Initiates a garbage collection. GEN controls the number of generations to garbage collect"
+ #!+(and sb-doc (not gencgc))
+ "Initiates a garbage collection. GEN may be provided for compatibility, but is ignored"
(sub-gc :force-p t :gen (if full 6 gen)))
+
\f
;;;; auxiliary functions
;; where his error was detected instead of telling him where
;; he ended up inside the system error-handling logic.
(declare (ignorable name ,fp ,context ,sc-offsets))
- (/show0 "about to do outer LETs in DEFERR macroexpanded DEFUN")
(let (,@(let ((offset -1))
(mapcar #'(lambda (var)
`(,var (sb!di::sub-access-debug-var-slot
+++ /dev/null
-;;;; This software is part of the SBCL system. See the README file for
-;;;; more information.
-;;;;
-;;;; This software is derived from the CMU CL system, which was
-;;;; written at Carnegie Mellon University and released into the
-;;;; public domain. The software is in the public domain and is
-;;;; provided with absolutely no warranty. See the COPYING and CREDITS
-;;;; files for more information.
-
-(in-package "SB!IMPL")
-
-(defun featurep (x)
- #!+sb-doc
- "If X is an atom, see whether it is present in *FEATURES*. Also
- handle arbitrary combinations of atoms using NOT, AND, OR."
- (if (consp x)
- (case (car x)
- ((:not not)
- (if (cddr x)
- (error "too many subexpressions in feature expression: ~S" x)
- (not (featurep (cadr x)))))
- ((:and and) (every #'featurep (cdr x)))
- ((:or or) (some #'featurep (cdr x)))
- (t
- (error "unknown operator in feature expression: ~S." x)))
- (not (null (memq x *features*)))))
-
-;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; &KEY-argument-list-style list of alternating keywords and
-;;; arbitrary values, return a new &KEY-argument-list-style list with
-;;; all substitutions applied to it.
-;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if
-;;; efficiency mattered, why would we be using &KEY arguments at
-;;; all, much less renaming &KEY arguments?)
-;;;
-;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-key-args (rename-list key-args)
- (declare (type list rename-list key-args))
- ;; Walk through RENAME-LIST modifying RESULT as per each element in
- ;; RENAME-LIST.
- (do ((result (copy-list key-args))) ; may be modified below
- ((null rename-list) result)
- (destructuring-bind (old new) (pop rename-list)
- ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
- (declare (type symbol old new))
- ;; Walk through RESULT renaming any OLD key argument to NEW.
- (do ((in-result result (cddr in-result)))
- ((null in-result))
- (declare (type list in-result))
- (when (eq (car in-result) old)
- (setf (car in-result) new))))))
-
-;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
-;;; other ANSI input functions, is defined to communicate end of file
-;;; status with its return value, not by signalling. This is not the
-;;; behavior we usually want. This is a wrapper which give the
-;;; behavior we usually want, causing READ-SEQUENCE to communicate
-;;; end-of-file status by signalling.
-(defun read-sequence-or-die (sequence stream &key start end)
- ;; implementation using READ-SEQUENCE
- #-no-ansi-read-sequence
- (let ((read-end (read-sequence sequence
- stream
- :start start
- :end end)))
- (unless (= read-end end)
- (error 'end-of-file :stream stream))
- (values))
- ;; workaround for broken READ-SEQUENCE
- #+no-ansi-read-sequence
- (progn
- (aver (<= start end))
- (let ((etype (stream-element-type stream)))
- (cond ((equal etype '(unsigned-byte 8))
- (do ((i start (1+ i)))
- ((>= i end)
- (values))
- (setf (aref sequence i)
- (read-byte stream))))
- (t (error "unsupported element type ~S" etype))))))
(let* ((fhsss sb!c:*fasl-header-string-start-string*)
(fhsss-length (length fhsss)))
(unless (= byte (char-code (schar fhsss 0)))
- (error "illegal fasl file header"))
+ (error "illegal fasl file header: first byte"))
(do ((byte (read-byte stream) (read-byte stream))
(count 1 (1+ count)))
((= byte sb!c:*fasl-header-string-stop-char-code*)
(declare (fixnum byte count))
(when (and (< count fhsss-length)
(not (eql byte (char-code (schar fhsss count)))))
- (error "illegal fasl file header"))))
+ (error "illegal fasl file header: subsequent byte"))))
;; Read and validate implementation and version, or die.
(let* ((implementation-length (read-arg 4))
(in-package "SB!INT")
\f
;;;; various SB-SHOW-dependent forms
+;;;;
+;;;; In general, macros named /FOO
+;;;; * are for debugging/tracing
+;;;; * expand into nothing unless :SB-SHOW is in the target
+;;;; features list
+;;;; Often, they also do nothing at runtime if */SHOW* is NIL, but
+;;;; this is not always true for some very-low-level ones.
+;;;;
+;;;; (I follow the "/FOO for debugging/tracing expressions" naming
+;;;; rule and several other naming conventions in all my Lisp
+;;;; programming when possible, and then set Emacs to display comments
+;;;; in one shade of blue, tracing expressions in another shade of
+;;;; blue, and declarations and assertions in a yellowish shade, so
+;;;; that it's easy to separate them from the "real code" which
+;;;; actually does the work of the program. -- WHN 2001-05-07)
;;; Set this to NIL to suppress output from /SHOW-related forms.
#!+sb-show (defvar */show* t)
(%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type))
variable)
+#!+(or x86 mips) ;; only backends for which a symbol-hash vop exists
(defun symbol-hash (symbol)
#!+sb-doc
"Return the built-in hash value for symbol."
(symbol-hash symbol))
+#!-(or x86 mips)
+(defun symbol-hash (symbol)
+ #!+sb-doc
+ "Return the built-in hash value for symbol."
+ (%sxhash-simple-string (symbol-name symbol)))
+
+
(defun symbol-function (variable)
#!+sb-doc
"VARIABLE must evaluate to a symbol. This symbol's current definition
values)
(defun %enumerate-search-list (pathname function)
- (/show0 "entering %ENUMERATE-SEARCH-LIST")
(let* ((pathname (if (typep pathname 'logical-pathname)
(translate-logical-pathname pathname)
pathname))
(search-list (extract-search-list pathname nil)))
- (/show0 "PATHNAME and SEARCH-LIST computed")
(cond
((not search-list)
- (/show0 "no search list")
(funcall function pathname))
((not (search-list-defined search-list))
- (/show0 "undefined search list")
(error "undefined search list: ~A"
(search-list-name search-list)))
(t
- (/show0 "general case")
(let ((tail (cddr (pathname-directory pathname))))
- (/show0 "TAIL computed")
(dolist (expansion
(search-list-expansions search-list))
- (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST")
(%enumerate-search-list (make-pathname :defaults pathname
:directory
(cons :absolute
(def-alien-type caddr-t (* char))
(def-alien-type swblk-t long)
(def-alien-type size-t unsigned-int)
-(def-alien-type time-t long)
-(def-alien-type clock-t
- #!+linux long
- #!+bsd unsigned-long)
-(def-alien-type uid-t unsigned-int)
(def-alien-type ssize-t int)
;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
;;; those functions in C as a wrapper layer.
(def-alien-type fd-mask unsigned-long)
-;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
-(def-alien-type dev-t
- #!+linux uquad-t
- #!+bsd unsigned-int)
-(def-alien-type uid-t unsigned-int)
-(def-alien-type gid-t unsigned-int)
-(def-alien-type ino-t
- #!+linux unsigned-long
- #!+bsd unsigned-int)
-(def-alien-type mode-t
- #!+linux unsigned-int
- #!+bsd unsigned-short)
-(def-alien-type nlink-t
- #!+linux unsigned-int
- #!+bsd unsigned-short)
-(/show0 "unix.lisp 263")
-
-;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
-;;; unless we have extreme provocation. Reading directories is not extreme
-;;; enough, since it doesn't need to be blindingly fast: we can just implement
-;;; those functions in C as a wrapper layer.
-
-(def-alien-type off-t
- #!+linux long
- #!+bsd quad-t)
-
-(defconstant fd-setsize 1024)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant fd-setsize 1024))
(def-alien-type nil
(struct fd-set
(/show0 "unix.lisp 304")
\f
-;;;; direntry.h
-;;;; dirent.h
-;;;;
-;;;; (CMU CL copied stuff out of these, but as of 0.6.11.41, SBCL
-;;;; doesn't need to, instead calling C-level wrapper code to handle
-;;;; all the opendir/readdir/closedir stuff.)
\f
;;;; fcntl.h
;;;;
;;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
-(/show0 "unix.lisp 356")
-(defconstant r_ok 4 #!+sb-doc "Test for read permission")
-(defconstant w_ok 2 #!+sb-doc "Test for write permission")
-(defconstant x_ok 1 #!+sb-doc "Test for execute permission")
-(defconstant f_ok 0 #!+sb-doc "Test for presence of file")
-
;;; Open the file whose pathname is specified by PATH for reading
;;; and/or writing as specified by the FLAGS argument. Various FLAGS
;;; masks (O_RDONLY etc.) are defined in fcntlbits.h.
(declare (type unix-fd fd))
(void-syscall ("close" int) fd))
\f
-;;;; fcntlbits.h
-
-(/show0 "unix.lisp 337")
-(defconstant o_rdonly 0) ; read-only flag
-(defconstant o_wronly 1) ; write-only flag
-(defconstant o_rdwr 2) ; read/write flag
-(defconstant o_accmode 3) ; access mode mask
-(defconstant o_creat ; create-if-nonexistent flag (not fcntl)
- #!+linux #o100
- #!+bsd #x0200)
-(/show0 "unix.lisp 345")
-(defconstant o_excl ; error if already exists (not fcntl)
- #!+linux #o200
- #!+bsd #x0800)
-(defconstant o_noctty ; Don't assign controlling tty. (not fcntl)
- #!+linux #o400
- #!+bsd #x8000)
-(defconstant o_trunc ; truncation flag (not fcntl)
- #!+linux #o1000
- #!+bsd #x0400)
-(defconstant o_append ; append flag
- #!+linux #o2000
- #!+bsd #x0008)
-(/show0 "unix.lisp 361")
-\f
;;;; timebits.h
;; A time value that is accurate to the nearest
(ru-nvcsw long) ; voluntary context switches
(ru-nivcsw long))) ; involuntary context switches
\f
-;;;; statbuf.h
-;;; FIXME: This should go into C code so that we don't need to hand-copy
-;;; it from header files.
-#!+Linux
+;;;; runtime/stat-wrapper.h
+\f
+;;; this looks like "struct stat" according to stat(2). It may not
+;;; correspond to the real in-memory stat structure that the syscall
+;;; uses, and if it doesn't, shouldn't. Linux in particular is packed
+;;; full of stat macros, so we do this stuff in runtime/stat-wrapper.c
+
+;;; Note that st-dev is a long, not a dev-t. This is because dev-t on
+;;; linux 32 bit archs is a 64 bit quantity, but alien doesn's support
+;;; those. We don't actually access that field anywhere, though, so until
+;;; we can get 64 bit alien support it'll do
+
(def-alien-type nil
(struct stat
- (st-dev dev-t)
- (st-pad1 unsigned-short)
+ (st-dev unsigned-long) ;would be dev-t in a real stat
(st-ino ino-t)
(st-mode mode-t)
(st-nlink nlink-t)
(st-uid uid-t)
(st-gid gid-t)
- (st-rdev dev-t)
- (st-pad2 unsigned-short)
+ (st-rdev unsigned-long) ;ditto
(st-size off-t)
(st-blksize unsigned-long)
(st-blocks unsigned-long)
(st-atime time-t)
- (unused-1 unsigned-long)
(st-mtime time-t)
- (unused-2 unsigned-long)
- (st-ctime time-t)
- (unused-3 unsigned-long)
- (unused-4 unsigned-long)
- (unused-5 unsigned-long)))
+ (st-ctime time-t)))
-#!+bsd
-(def-alien-type nil
- (struct timespec-t
- (tv-sec long)
- (tv-nsec long)))
-
-#!+bsd
-(def-alien-type nil
- (struct stat
- (st-dev dev-t)
- (st-ino ino-t)
- (st-mode mode-t)
- (st-nlink nlink-t)
- (st-uid uid-t)
- (st-gid gid-t)
- (st-rdev dev-t)
- (st-atime (struct timespec-t))
- (st-mtime (struct timespec-t))
- (st-ctime (struct timespec-t))
- (st-size unsigned-long) ; really quad
- (st-sizeh unsigned-long) ;
- (st-blocks unsigned-long) ; really quad
- (st-blocksh unsigned-long)
- (st-blksize unsigned-long)
- (st-flags unsigned-long)
- (st-gen unsigned-long)
- (st-lspare long)
- (st-qspare (array long 4))
- ))
-
-;; encoding of the file mode
-
-;;; These bits determine file type.
-(defconstant s-ifmt #o0170000)
-
-;; basic file types, exist even on System V
-(defconstant s-ififo #o0010000) ; FIFO
-(defconstant s-ifchr #o0020000) ; Character device
-(defconstant s-ifdir #o0040000) ; Directory
-(defconstant s-ifblk #o0060000) ; Block device
-(defconstant s-ifreg #o0100000) ; Regular file
-
-;; more file types: These don't actually exist on System V, but having
-;; them doesn't hurt.
-(defconstant s-iflnk #o0120000) ; Symbolic link
-(defconstant s-ifsock #o0140000) ; Socket
-\f
;;;; unistd.h
;;; Given a file path (a string) and one of four constant modes,
;;; runtime. It's also unclear why it needs to be a macro instead of a
;;; function. Perhaps it should become a FLET.
(defmacro extract-stat-results (buf)
- `(values T
- #!+bsd
+ `(values T ; result
(slot ,buf 'st-dev)
- #!+linux
- (+ (deref (slot ,buf 'st-dev) 0)
- (* (+ +max-u-long+ 1)
- (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works..
(slot ,buf 'st-ino)
(slot ,buf 'st-mode)
(slot ,buf 'st-nlink)
(slot ,buf 'st-uid)
(slot ,buf 'st-gid)
- #!+bsd
(slot ,buf 'st-rdev)
- #!+linux
- (+ (deref (slot ,buf 'st-rdev) 0)
- (* (+ +max-u-long+ 1)
- (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works..
- #!+linux (slot ,buf 'st-size)
- #!+bsd
- (+ (slot ,buf 'st-size)
- (* (+ +max-u-long+ 1)
- (slot ,buf 'st-sizeh)))
- #!+linux (slot ,buf 'st-atime)
- #!+bsd (slot (slot ,buf 'st-atime) 'tv-sec)
- #!+linux (slot ,buf 'st-mtime)
- #!+bsd (slot (slot ,buf 'st-mtime) 'tv-sec)
- #!+linux (slot ,buf 'st-ctime)
- #!+bsd (slot (slot ,buf 'st-ctime) 'tv-sec)
+ (slot ,buf 'st-size)
+ (slot ,buf 'st-atime)
+ (slot ,buf 'st-mtime)
+ (slot ,buf 'st-ctime)
(slot ,buf 'st-blksize)
- #!+linux (slot ,buf 'st-blocks)
- #!+bsd
- (+ (slot ,buf 'st-blocks)
- (* (+ +max-u-long+ 1)
- (slot ,buf 'st-blocksh)))
- ))
+ (slot ,buf 'st-blocks)))
;;; Retrieve information about the specified file returning them in
;;; the form of multiple values. See the UNIX Programmer's Manual for
;;; a description of the values returned. If the call fails, then NIL
;;; and an error number is returned instead.
+
(defun unix-stat (name)
(declare (type unix-pathname name))
(when (string= name "")
(setf name "."))
(with-alien ((buf (struct stat)))
- (syscall ("stat" c-string (* (struct stat)))
+ (syscall ("stat_wrapper" c-string (* (struct stat)))
+ (extract-stat-results buf)
+ name (addr buf))))
+
+(defun unix-lstat (name)
+ #!+sb-doc
+ "Unix-lstat is identical to unix-stat, except if NAME is
+ a symlink, in which case it returns information about the
+ link itself rather than dereferencing it."
+ (declare (type unix-pathname name))
+ (with-alien ((buf (struct stat)))
+ (syscall ("lstat_wrapper" c-string (* (struct stat)))
(extract-stat-results buf)
name (addr buf))))
(defun unix-fstat (fd)
(declare (type unix-fd fd))
(with-alien ((buf (struct stat)))
- (syscall ("fstat" int (* (struct stat)))
+ (syscall ("fstat_wrapper" int (* (struct stat)))
(extract-stat-results buf)
fd (addr buf))))
-;;; like UNIX-STAT except the specified file must be a symbolic link
-(defun unix-lstat (name)
- (declare (type unix-pathname name))
- (with-alien ((buf (struct stat)))
- (syscall ("lstat" c-string (* (struct stat)))
- (extract-stat-results buf)
- name (addr buf))))
;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
;;; corresponding directory with mode mode.
(addr tv)
(addr tz))))
\f
-;;;; asm/errno.h
(defconstant ENOENT 2) ; Unix error code, "No such file or directory"
(defconstant EINTR 4) ; Unix error code, "Interrupted system call"
;;; enough of them all in one place here that they should probably be
;;; removed by hand.
\f
+\f
;;;; support routines for dealing with Unix pathnames
(defun unix-file-kind (name &optional check-for-links)
,@(loop for index upfrom 0 below (/ fd-setsize 32)
collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
-(/show0 "unix.lisp 3555")
+
cl)
(kernel:%set-symbol-package symbol cl))))
standard-ht))
+
+#+(and cmu alpha)
+(unless (ignore-errors (read-from-string "1.0l0"))
+ (error "CMUCL on Alpha can't read floats in the format \"1.0l0\". Patch your core file~%~%"))
+
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-;;; TO DO: Might it be possible to increase the efficiency of CMU CL's garbage
-;;; collection on my large (256Mb) machine by doing larger incremental GC steps
-;;; than the default 2 Mb of CMU CL 2.4.9? A quick test 19990729, setting this
-;;; to 5E6 showed no significant improvement, but it's possible that more
-;;; cleverness might help..
-;#+cmu (setf ext:*bytes-consed-between-gcs* (* 5 (expt 10 6)))
+;;; GC tuning has little effect on the x86 due to the generational
+;;; collector. For the older stop & copy collector, it assuredly
+;;; does. GC time is proportional to the amount of non-grabage
+;;; needing collection and copying; when the application involved is
+;;; the SBCL compiler, it doesn't take any longer to collect 20Mb than
+;;; 2 -dan, 20000819
+
+#+sbcl
+(progn
+ (sb-ext:gc-off)
+ (setf sb-KERNEL::*bytes-consed-between-gcs* (* 20 (expt 10 6)))
+ (sb-ext:gc-on)
+ (sb-ext:gc))
;;; FIXME: I'm now inclined to make all the bootstrap stuff run in CL-USER
;;; instead of SB-COLD. If I do so, I should first take care to
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Allocation VOPs for the Alpha port.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+\f
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+ (:args (things :more t))
+ (:temporary (:scs (descriptor-reg) :type list) ptr)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
+ res)
+ (:info num)
+ (:results (result :scs (descriptor-reg)))
+ (:variant-vars star)
+ (:policy :safe)
+ (:generator 0
+ (cond ((zerop num)
+ (move null-tn result))
+ ((and star (= num 1))
+ (move (tn-ref-tn things) result))
+ (t
+ (macrolet
+ ((store-car (tn list &optional (slot cons-car-slot))
+ `(let ((reg
+ (sc-case ,tn
+ ((any-reg descriptor-reg) ,tn)
+ (zero zero-tn)
+ (null null-tn)
+ (control-stack
+ (load-stack-tn temp ,tn)
+ temp))))
+ (storew reg ,list ,slot list-pointer-type))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic (:extra (* (pad-data-block cons-size)
+ cons-cells))
+ (inst bis alloc-tn list-pointer-type res)
+ (move res ptr)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (setf things (tn-ref-across things))
+ (inst lda ptr (pad-data-block cons-size) ptr)
+ (storew ptr ptr
+ (- cons-cdr-slot cons-size)
+ list-pointer-type))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew null-tn ptr
+ cons-cdr-slot list-pointer-type)))
+ (assert (null (tn-ref-across things)))
+ (move res result))))))))
+
+(define-vop (list list-or-list*)
+ (:variant nil))
+
+(define-vop (list* list-or-list*)
+ (:variant t))
+
+\f
+;;;; Special purpose inline allocators.
+
+(define-vop (allocate-code-object)
+ (:args (boxed-arg :scs (any-reg))
+ (unboxed-arg :scs (any-reg)))
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
+ (:generator 100
+ (inst li (lognot lowtag-mask) ndescr)
+ (inst lda boxed (fixnumize (1+ code-trace-table-offset-slot))
+ boxed-arg)
+ (inst and boxed ndescr boxed)
+ (inst srl unboxed-arg word-shift unboxed)
+ (inst lda unboxed lowtag-mask unboxed)
+ (inst and unboxed ndescr unboxed)
+ (inst sll boxed (- type-bits word-shift) ndescr)
+ (inst bis ndescr code-header-type ndescr)
+
+ (pseudo-atomic ()
+ (inst bis alloc-tn other-pointer-type result)
+ (storew ndescr result 0 other-pointer-type)
+ (storew unboxed result code-code-size-slot other-pointer-type)
+ (storew null-tn result code-entry-points-slot other-pointer-type)
+ (inst addq alloc-tn boxed alloc-tn)
+ (inst addq alloc-tn unboxed alloc-tn))
+
+ (storew null-tn 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 (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (descriptor-reg) :from :argument))
+ (:generator 37
+ (with-fixed-allocation (result temp fdefn-type fdefn-size)
+ (storew name result fdefn-name-slot other-pointer-type)
+ (storew null-tn result fdefn-function-slot other-pointer-type)
+ (inst li (make-fixup "undefined_tramp" :foreign) temp)
+ (storew temp result fdefn-raw-addr-slot other-pointer-type))))
+
+(define-vop (make-closure)
+ (:args (function :to :save :scs (descriptor-reg)))
+ (:info length)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (let ((size (+ length closure-info-offset)))
+ (inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
+ (pseudo-atomic (:extra (pad-data-block size))
+ (inst bis alloc-tn function-pointer-type result)
+ (storew temp result 0 function-pointer-type))
+ (storew function result closure-function-slot function-pointer-type))))
+
+;;; The compiler likes to be able to directly make value cells.
+;;;
+(define-vop (make-value-cell)
+ (:args (value :to :save :scs (descriptor-reg any-reg null zero)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 10
+ (with-fixed-allocation
+ (result temp value-cell-header-type value-cell-size))
+ (storew value result value-cell-value-slot other-pointer-type)))
+
+\f
+;;;; Automatic allocators for primitive objects.
+
+(define-vop (make-unbound-marker)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst li unbound-marker-type result)))
+
+(define-vop (fixed-alloc)
+ (:args)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 4
+ (pseudo-atomic (:extra (pad-data-block words))
+ (inst bis alloc-tn lowtag result)
+ (when type
+ (inst li (logior (ash (1- words) type-bits) type) temp)
+ (storew temp result 0 lowtag)))))
+
+(define-vop (var-alloc)
+ (:args (extra :scs (any-reg)))
+ (:arg-types positive-fixnum)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) header)
+ (:temporary (:scs (non-descriptor-reg)) bytes)
+ (:generator 6
+ (inst lda bytes (* (1+ words) word-bytes) extra)
+ (inst sll bytes (- type-bits 2) header)
+ (inst lda header (+ (ash -2 type-bits) type) header)
+ (inst srl bytes lowtag-bits bytes)
+ (inst sll bytes lowtag-bits bytes)
+ (pseudo-atomic ()
+ (inst bis alloc-tn lowtag result)
+ (storew header result 0 lowtag)
+ (inst addq alloc-tn bytes alloc-tn))))
--- /dev/null
+;;; -*- Package: ALPHA; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header$
+;;;
+;;; This file contains the VM definition arithmetic VOPs for the MIPS.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted by Sean Hallgren
+;;;
+
+(in-package "SB!VM")
+
+
+
+\f
+;;;; Unary operations.
+
+(define-vop (fixnum-unop)
+ (:args (x :scs (any-reg)))
+ (:results (res :scs (any-reg)))
+ (:note "inline fixnum arithmetic")
+ (:arg-types tagged-num)
+ (:result-types tagged-num)
+ (:policy :fast-safe))
+
+(define-vop (signed-unop)
+ (:args (x :scs (signed-reg)))
+ (:results (res :scs (signed-reg)))
+ (:note "inline (signed-byte 32) arithmetic")
+ (:arg-types signed-num)
+ (:result-types signed-num)
+ (:policy :fast-safe))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+ (:translate %negate)
+ (:generator 1
+ (inst subq zero-tn x res)))
+
+(define-vop (fast-negate/signed signed-unop)
+ (:translate %negate)
+ (:generator 2
+ (inst subq zero-tn x res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:translate lognot)
+ (:generator 2
+ (inst eqv x zero-tn res)))
+
+(define-vop (fast-lognot/signed signed-unop)
+ (:translate lognot)
+ (:generator 1
+ (inst not x res)))
+
+
+\f
+;;;; Binary fixnum operations.
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-signed-c-binop fast-signed-binop)
+ (:args (x :target r :scs (signed-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg)))
+ (:info y)
+ (:arg-types tagged-num (:constant integer)))
+
+(defmacro define-binop (translate cost untagged-cost op
+ tagged-type untagged-type)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:args (x :target r :scs (any-reg))
+ (y :target r :scs (any-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ cost)
+ (inst ,op x y r)))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:args (x :target r :scs (signed-reg))
+ (y :target r :scs (signed-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ untagged-cost)
+ (inst ,op x y r)))
+ (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:args (x :target r :scs (unsigned-reg))
+ (y :target r :scs (unsigned-reg)))
+ (:translate ,translate)
+ (:generator ,(1+ untagged-cost)
+ (inst ,op x y r)))
+ ,@(when tagged-type
+ `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
+ fast-fixnum-c-binop)
+ (:arg-types tagged-num (:constant ,tagged-type))
+ (:translate ,translate)
+ (:generator ,cost
+ (inst ,op x (fixnumize y) r)))))
+ ,@(when untagged-type
+ `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
+ fast-signed-c-binop)
+ (:arg-types signed-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op x y r)))
+ (define-vop (,(symbolicate "FAST-" translate
+ "-C/UNSIGNED=>UNSIGNED")
+ fast-unsigned-c-binop)
+ (:arg-types unsigned-num (:constant ,untagged-type))
+ (:translate ,translate)
+ (:generator ,untagged-cost
+ (inst ,op x y r)))))))
+
+(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
+(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
+(define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
+(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
+
+
+;;; Shifting
+
+
+(define-vop (fast-ash)
+ (:note "inline ASH")
+ (:args (number :scs (signed-reg unsigned-reg) :to :save)
+ (amount :scs (signed-reg)))
+ (:arg-types (:or signed-num unsigned-num) signed-num)
+ (:results (result :scs (signed-reg unsigned-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:translate ash)
+ (:policy :fast-safe)
+ (:temporary (:sc non-descriptor-reg) ndesc)
+ (:temporary (:sc non-descriptor-reg :to :eval) temp)
+ (:generator 3
+ (inst bge amount positive)
+ (inst subq zero-tn amount ndesc)
+ (inst cmplt ndesc 31 temp)
+ (sc-case number
+ (signed-reg (inst sra number ndesc result))
+ (unsigned-reg (inst srl number ndesc result)))
+ (inst bne temp done)
+ (sc-case number
+ (signed-reg (inst sra number 31 result))
+ (unsigned-reg (inst srl number 31 result)))
+ (inst br zero-tn done)
+
+ POSITIVE
+ ;; The result-type assures us that this shift will not overflow.
+ (inst sll number amount result)
+
+ DONE))
+
+(define-vop (fast-ash-c)
+ (:policy :fast-safe)
+ (:translate ash)
+ (:note nil)
+ (:args (number :scs (signed-reg unsigned-reg)))
+ (:info count)
+ (:arg-types (:or signed-num unsigned-num) (:constant integer))
+ (:results (result :scs (signed-reg unsigned-reg)))
+ (:result-types (:or signed-num unsigned-num))
+ (:generator 1
+ (cond ((< count 0)
+ ;; It is a right shift.
+ (sc-case number
+ (signed-reg (inst sra number (- count) result))
+ (unsigned-reg (inst srl number (- count) result))))
+ ((> count 0)
+ ;; It is a left shift.
+ (inst sll number count result))
+ (t
+ ;; Count=0? Shouldn't happen, but it's easy:
+ (move number result)))))
+
+(define-vop (signed-byte-32-len)
+ (:translate integer-length)
+ (:note "inline (signed-byte 32) integer-length")
+ (:policy :fast-safe)
+ (:args (arg :scs (signed-reg) :to (:argument 1)))
+ (:arg-types signed-num)
+ (:results (res :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
+ (:generator 30
+ (inst not arg shift)
+ (inst cmovge arg arg shift)
+ (inst subq zero-tn 4 res)
+ (inst sll shift 1 shift)
+ LOOP
+ (inst addq res (fixnumize 1) res)
+ (inst srl shift 1 shift)
+ (inst bne shift loop)))
+
+(define-vop (unsigned-byte-32-count)
+ (:translate logcount)
+ (:note "inline (unsigned-byte 32) logcount")
+ (:policy :fast-safe)
+ (:args (arg :scs (unsigned-reg) :target num))
+ (:arg-types unsigned-num)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
+ :target res) num)
+ (:temporary (:scs (non-descriptor-reg)) mask temp)
+ (:generator 30
+ (inst li #x55555555 mask)
+ (inst srl arg 1 temp)
+ (inst and arg mask num)
+ (inst and temp mask temp)
+ (inst addq num temp num)
+ (inst li #x33333333 mask)
+ (inst srl num 2 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst addq num temp num)
+ (inst li #x0f0f0f0f mask)
+ (inst srl num 4 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst addq num temp num)
+ (inst li #x00ff00ff mask)
+ (inst srl num 8 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst addq num temp num)
+ (inst li #x0000ffff mask)
+ (inst srl num 16 temp)
+ (inst and num mask num)
+ (inst and temp mask temp)
+ (inst addq num temp res)))
+
+
+;;; Multiply
+
+(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:translate *)
+ (:generator 4
+ (inst sra y 2 temp)
+ (inst mulq x temp r)))
+
+(define-vop (fast-*/signed=>signed fast-signed-binop)
+ (:translate *)
+ (:generator 3
+ (inst mulq x y r)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
+ (:translate *)
+ (:generator 3
+ (inst mulq x y r)))
+
+
+\f
+;;;; Binary conditional VOPs:
+
+(define-vop (fast-conditional)
+ (:conditional)
+ (:info target not-p)
+ (:effects)
+ (:affected)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:policy :fast-safe))
+
+(deftype integer-with-a-bite-out (s bite)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 1))
+ (let ((bound (ash 1 s)))
+ `(integer 0 ,(- bound bite 1))))
+ (t
+ (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+ (:args (x :scs (any-reg))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg)))
+ (:arg-types tagged-num (:constant (integer-with-a-bite-out 6 4)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+ (:args (x :scs (signed-reg))
+ (y :scs (signed-reg)))
+ (:arg-types signed-num signed-num)
+ (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+ (:args (x :scs (signed-reg)))
+ (:arg-types signed-num (:constant (integer-with-a-bite-out 8 1)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+ (:args (x :scs (unsigned-reg)))
+ (:arg-types unsigned-num (:constant (integer-with-a-bite-out 8 1)))
+ (:info target not-p y))
+
+
+(defmacro define-conditional-vop (translate &rest generator)
+ `(progn
+ ,@(mapcar #'(lambda (suffix cost signed)
+ (unless (and (member suffix '(/fixnum -c/fixnum))
+ (eq translate 'eql))
+ `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ translate suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,translate)
+ (:generator ,cost
+ (let* ((signed ,signed)
+ (-c/fixnum ,(eq suffix '-c/fixnum))
+ (y (if -c/fixnum (fixnumize y) y)))
+ ,@generator)))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(3 2 5 4 5 4)
+ '(t t t t nil nil))))
+
+(define-conditional-vop <
+ (cond ((and signed (eql y 0))
+ (if not-p
+ (inst bge x target)
+ (inst blt x target)))
+ (t
+ (if signed
+ (inst cmplt x y temp)
+ (inst cmpult x y temp))
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target)))))
+
+(define-conditional-vop >
+ (cond ((and signed (eql y 0))
+ (if not-p
+ (inst ble x target)
+ (inst bgt x target)))
+ ((integerp y)
+ (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
+ (if signed
+ (inst cmplt x y temp)
+ (inst cmpult x y temp))
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))))
+ (t
+ (if signed
+ (inst cmplt y x temp)
+ (inst cmpult y x temp))
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target)))))
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+(define-conditional-vop eql
+ (declare (ignore signed))
+ (when (integerp y)
+ (inst li y temp)
+ (setf y temp))
+ (inst cmpeq x y temp)
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target)))
+
+;;; These versions specify a fixnum restriction on their first arg. We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost. The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+;;;
+(define-vop (fast-eql/fixnum fast-conditional)
+ (:args (x :scs (any-reg))
+ (y :scs (any-reg)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison")
+ (:translate eql)
+ (:generator 3
+ (cond ((equal y zero-tn)
+ (if not-p
+ (inst bne x target)
+ (inst beq x target)))
+ (t
+ (inst cmpeq x y temp)
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target))))))
+
+;;;
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+ (:args (x :scs (any-reg descriptor-reg))
+ (y :scs (any-reg)))
+ (:arg-types * tagged-num)
+ (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg)))
+ (:arg-types tagged-num (:constant (signed-byte 6)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:info target not-p y)
+ (:translate eql)
+ (:generator 2
+ (let ((y (cond ((eql y 0) zero-tn)
+ (t
+ (inst li (fixnumize y) temp)
+ temp))))
+ (inst cmpeq x y temp)
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target)))))
+;;;
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+ (:args (x :scs (any-reg descriptor-reg)))
+ (:arg-types * (:constant (signed-byte 6)))
+ (:variant-cost 6))
+
+\f
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+ (:translate merge-bits)
+ (:args (shift :scs (signed-reg unsigned-reg))
+ (prev :scs (unsigned-reg))
+ (next :scs (unsigned-reg)))
+ (:arg-types tagged-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 4
+ (let ((done (gen-label)))
+ (inst srl next shift res)
+ (inst beq shift done)
+ (inst subq zero-tn shift temp)
+ (inst sll prev temp temp)
+ (inst bis res temp res)
+ (emit-label done)
+ (move res result))))
+
+
+(define-vop (32bit-logical)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe))
+
+(define-vop (32bit-logical-not 32bit-logical)
+ (:translate 32bit-logical-not)
+ (:args (x :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:generator 2
+ (inst not x r)
+ (inst mskll r 4 r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+ (:translate 32bit-logical-and)
+ (:generator 1
+ (inst and x y r)))
+
+(deftransform 32bit-logical-nand ((x y) (* *))
+ '(32bit-logical-not (32bit-logical-and x y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+ (:translate 32bit-logical-or)
+ (:generator 1
+ (inst bis x y r)))
+
+(define-vop (32bit-logical-nor 32bit-logical)
+ (:translate 32bit-logical-nor)
+ (:generator 2
+ (inst ornot x y r)
+ (inst mskll r 4 r)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+ (:translate 32bit-logical-xor)
+ (:generator 1
+ (inst xor x y r)))
+
+(deftransform 32bit-logical-eqv ((x y) (* *))
+ '(32bit-logical-not (32bit-logical-xor x y)))
+
+(deftransform 32bit-logical-andc1 ((x y) (* *))
+ '(32bit-logical-and (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-andc2 ((x y) (* *))
+ '(32bit-logical-and x (32bit-logical-not y)))
+
+(deftransform 32bit-logical-orc1 ((x y) (* *))
+ '(32bit-logical-or (32bit-logical-not x) y))
+
+(deftransform 32bit-logical-orc2 ((x y) (* *))
+ '(32bit-logical-or x (32bit-logical-not y)))
+
+
+(define-vop (shift-towards-someplace)
+ (:policy :fast-safe)
+ (:args (num :scs (unsigned-reg))
+ (amount :scs (signed-reg)))
+ (:arg-types unsigned-num tagged-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+ (:translate shift-towards-start)
+ (:note "SHIFT-TOWARDS-START")
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:generator 1
+ (inst and amount #x1f temp)
+ (inst srl num temp r)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+ (:translate shift-towards-end)
+ (:note "SHIFT-TOWARDS-END")
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:generator 1
+ (inst and amount #x1f temp)
+ (inst sll num temp r)))
+
+
+\f
+;;;; Bignum stuff.
+
+(define-vop (bignum-length get-header-data)
+ (:translate sb!bignum::%bignum-length)
+ (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+ (:translate sb!bignum::%bignum-set-length)
+ (:policy :fast-safe))
+
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-set #+gengc nil)
+
+(define-vop (digit-0-or-plus)
+ (:translate sb!bignum::%digit-0-or-plusp)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:conditional)
+ (:info target not-p)
+ (:generator 2
+ (inst sll digit 32 temp)
+ (if not-p
+ (inst blt temp target)
+ (inst bge temp target))))
+
+(define-vop (add-w/carry)
+ (:translate sb!bignum::%add-with-carry)
+ (:policy :fast-safe)
+ (:args (a :scs (unsigned-reg))
+ (b :scs (unsigned-reg))
+ (c :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from :load)
+ (carry :scs (unsigned-reg) :from :eval))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 5
+ (inst addq a b result)
+ (inst addq result c result)
+ (inst sra result 32 carry)
+ (inst mskll result 4 result)))
+
+(define-vop (sub-w/borrow)
+ (:translate sb!bignum::%subtract-with-borrow)
+ (:policy :fast-safe)
+ (:args (a :scs (unsigned-reg))
+ (b :scs (unsigned-reg))
+ (c :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from :load)
+ (borrow :scs (unsigned-reg) :from :eval))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 4
+ (inst xor c 1 result)
+ (inst subq a result result)
+ (inst subq result b result)
+ (inst srl result 63 borrow)
+ (inst xor borrow 1 borrow)
+ (inst mskll result 4 result)))
+
+(define-vop (bignum-mult-and-add-3-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 6
+ (inst mulq x y lo)
+ (inst addq lo carry-in lo)
+ (inst sra lo 32 hi)
+ (inst mskll lo 4 lo)))
+
+
+(define-vop (bignum-mult-and-add-4-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg))
+ (prev :scs (unsigned-reg))
+ (carry-in :scs (unsigned-reg) :to :save))
+ (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 9
+ (inst mulq x y lo)
+ (inst addq lo prev lo)
+ (inst addq lo carry-in lo)
+ (inst sra lo 32 hi)
+ (inst mskll lo 4 lo)))
+
+(define-vop (bignum-mult)
+ (:translate sb!bignum::%multiply)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg))
+ (y :scs (unsigned-reg)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 3
+ (inst mulq x y lo)
+ (inst srl lo 32 hi)
+ (inst mskll lo 4 lo)))
+
+(define-vop (bignum-lognot)
+ (:translate sb!bignum::%lognot)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (r :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (inst not x r)
+ (inst mskll r 4 r)))
+
+(define-vop (fixnum-to-digit)
+ (:translate sb!bignum::%fixnum-to-digit)
+ (:policy :fast-safe)
+ (:args (fixnum :scs (any-reg)))
+ (:arg-types tagged-num)
+ (:results (digit :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (inst sra fixnum 2 digit)))
+
+(define-vop (bignum-floor)
+ (:translate sb!bignum::%floor)
+ (:policy :fast-safe)
+ (:args (num-high :scs (unsigned-reg))
+ (num-low :scs (unsigned-reg))
+ (denom-arg :scs (unsigned-reg) :target denom))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom)
+ (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
+ (:results (quo :scs (unsigned-reg) :from (:eval 0))
+ (rem :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 325 ; number of inst assuming targeting works.
+ (inst sll num-high 32 rem)
+ (inst bis rem num-low rem)
+ (inst sll denom-arg 32 denom)
+ (inst cmpule denom rem quo)
+ (inst beq quo shift1)
+ (inst subq rem denom rem)
+ SHIFT1
+ (dotimes (i 32)
+ (let ((shift2 (gen-label)))
+ (inst srl denom 1 denom)
+ (inst cmpule denom rem temp)
+ (inst sll quo 1 quo)
+ (inst beq temp shift2)
+ (inst subq rem denom rem)
+ (inst bis quo 1 quo)
+ (emit-label shift2)))))
+
+(define-vop (signify-digit)
+ (:translate sb!bignum::%fixnum-digit-with-correct-sign)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg) :target res))
+ (:arg-types unsigned-num)
+ (:results (res :scs (any-reg signed-reg)))
+ (:result-types signed-num)
+ (:generator 2
+ (sc-case res
+ (any-reg
+ (inst sll digit 34 res)
+ (inst sra res 32 res))
+ (signed-reg
+ (inst sll digit 32 res)
+ (inst sra res 32 res)))))
+
+
+(define-vop (digit-ashr)
+ (:translate sb!bignum::%ashr)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg))
+ (count :scs (unsigned-reg)))
+ (:arg-types unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (inst sll digit 32 result)
+ (inst sra result count result)
+ (inst srl result 32 result)))
+
+(define-vop (digit-lshr digit-ashr)
+ (:translate sb!bignum::%digit-logical-shift-right)
+ (:generator 1
+ (inst srl digit count result)))
+
+(define-vop (digit-ashl digit-ashr)
+ (:translate sb!bignum::%ashl)
+ (:generator 1
+ (inst sll digit count result)))
+
+\f
+;;;; Static functions.
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-+ (x y) :translate +)
+(define-static-function two-arg-- (x y) :translate -)
+(define-static-function two-arg-* (x y) :translate *)
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-< (x y) :translate <)
+(define-static-function two-arg-<= (x y) :translate <=)
+(define-static-function two-arg-> (x y) :translate >)
+(define-static-function two-arg->= (x y) :translate >=)
+(define-static-function two-arg-= (x y) :translate =)
+(define-static-function two-arg-/= (x y) :translate /=)
+
+(define-static-function %negate (x) :translate %negate)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the Alpha definitions for array operations.
+;;;
+;;; Written by William Lott
+;;; Conversion by Sean Hallgren
+;;; Complex-float support by Douglas Crosher 1998.
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; Allocator for the array header.
+
+(define-vop (make-array-header)
+ (:policy :fast-safe)
+ (:translate make-array-header)
+ (:args (type :scs (any-reg))
+ (rank :scs (any-reg)))
+ (:arg-types positive-fixnum positive-fixnum)
+ (:temporary (:scs (any-reg)) bytes)
+ (:temporary (:scs (non-descriptor-reg)) header)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 13
+ (inst addq rank (+ (* array-dimensions-offset word-bytes)
+ lowtag-mask)
+ bytes)
+ (inst li (lognot lowtag-mask) header)
+ (inst and bytes header bytes)
+ (inst addq rank (fixnumize (1- array-dimensions-offset)) header)
+ (inst sll header type-bits header)
+ (inst bis header type header)
+ (inst srl header 2 header)
+ (pseudo-atomic ()
+ (inst bis alloc-tn other-pointer-type result)
+ (storew header result 0 other-pointer-type)
+ (inst addq alloc-tn bytes alloc-tn))))
+
+
+\f
+;;;; Additional accessors and setters for the array header.
+
+(defknown sb!impl::%array-dimension (t index) index
+ (flushable))
+(defknown sb!impl::%set-array-dimension (t index index) index
+ ())
+
+(define-full-reffer %array-dimension *
+ array-dimensions-offset other-pointer-type
+ (any-reg) positive-fixnum sb!impl::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+ array-dimensions-offset other-pointer-type
+ (any-reg) positive-fixnum sb!impl::%set-array-dimension #+gengc nil)
+
+
+(defknown sb!impl::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+ (:translate sb!impl::%array-rank)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 6
+ (loadw temp x 0 other-pointer-type)
+ (inst sra temp type-bits temp)
+ (inst subq temp (1- array-dimensions-offset) temp)
+ (inst sll temp 2 res)))
+
+
+\f
+;;;; Bounds checking routine.
+
+
+(define-vop (check-bound)
+ (:translate %check-bound)
+ (:policy :fast-safe)
+ (:args (array :scs (descriptor-reg))
+ (bound :scs (any-reg descriptor-reg))
+ (index :scs (any-reg descriptor-reg) :target result))
+ (:results (result :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (let ((error (generate-error-code vop invalid-array-index-error
+ array bound index)))
+ (inst cmpult index bound temp)
+ (inst beq temp error)
+ (move index result))))
+
+
+\f
+;;;; Accessors/Setters
+
+;;; Variants built on top of word-index-ref, etc. I.e. those vectors whos
+;;; elements are represented in integer registers and are built out of
+;;; 8, 16, or 32 bit elements.
+
+(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ vector-data-offset other-pointer-type
+ ,(remove-if #'(lambda (x) (member x '(null zero))) scs)
+ ,element-type
+ data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ vector-data-offset other-pointer-type ,scs ,element-type
+ data-vector-set #+gengc ,(if (member 'descriptor-reg scs) t nil))))
+
+ (def-partial-data-vector-frobs
+ (type element-type size signed &rest scs)
+ `(progn
+ (define-partial-reffer ,(symbolicate "DATA-VECTOR-REF/" type) ,type
+ ,size ,signed vector-data-offset other-pointer-type ,scs
+ ,element-type data-vector-ref)
+ (define-partial-setter ,(symbolicate "DATA-VECTOR-SET/" type) ,type
+ ,size vector-data-offset other-pointer-type ,scs
+ ,element-type data-vector-set)))
+ (def-small-data-vector-frobs (type bits)
+ (let* ((elements-per-word (floor word-bits bits))
+ (bit-shift (1- (integer-length elements-per-word))))
+ `(progn
+ (define-vop (,(symbolicate 'data-vector-ref/ type))
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
+ (:generator 20
+ (inst srl index ,bit-shift temp)
+ (inst sll temp 2 temp)
+ (inst addq object temp lip)
+ (inst ldl result
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)
+ (inst and index ,(1- elements-per-word) temp)
+ ,@(unless (= bits 1)
+ `((inst sll temp ,(1- (integer-length bits)) temp)))
+ (inst srl result temp result)
+ (inst and result ,(1- (ash 1 bits)) result)
+ (inst sll result 2 value)))
+ (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:arg-types ,type
+ (:constant
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-type)
+ word-bytes)
+ vector-data-offset))
+ elements-per-word)))))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-type)
+ (unless (zerop extra)
+ (inst srl result (* extra ,bits) result))
+ (unless (= extra ,(1- elements-per-word))
+ (inst and result ,(1- (ash 1 bits)) result)))))
+ (define-vop (,(symbolicate 'data-vector-set/ type))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg) :target shift)
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
+ (:generator 25
+ (inst srl index ,bit-shift temp)
+ (inst sll temp 2 temp)
+ (inst addq object temp lip)
+ (inst ldl old
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)
+ (inst and index ,(1- elements-per-word) shift)
+ ,@(unless (= bits 1)
+ `((inst sll shift ,(1- (integer-length bits)) shift)))
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst li ,(1- (ash 1 bits)) temp)
+ (inst sll temp shift temp)
+ (inst not temp temp)
+ (inst and old temp old))
+ (unless (sc-is value zero)
+ (sc-case value
+ (immediate
+ (inst li (logand (tn-value value) ,(1- (ash 1 bits))) temp))
+ (unsigned-reg
+ (inst and value ,(1- (ash 1 bits)) temp)))
+ (inst sll temp shift temp)
+ (inst bis old temp old))
+ (inst stl old
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (zero
+ (move zero-tn result))
+ (unsigned-reg
+ (move value result)))))
+ (define-vop (,(symbolicate 'data-vector-set-c/ type))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg zero immediate) :target result))
+ (:arg-types ,type
+ (:constant
+ (integer 0
+ ,(1- (* (1+ (- (floor (+ #x7fff
+ other-pointer-type)
+ word-bytes)
+ vector-data-offset))
+ elements-per-word))))
+ positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:scs (non-descriptor-reg)) temp old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (inst ldl object
+ (- (* (+ word vector-data-offset) word-bytes)
+ other-pointer-type)
+ old)
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (cond ((= extra ,(1- elements-per-word))
+ (inst sll old ,bits old)
+ (inst srl old ,bits old))
+ (t
+ (inst li
+ (lognot (ash ,(1- (ash 1 bits)) (* extra ,bits)))
+ temp)
+ (inst and old temp old))))
+ (sc-case value
+ (zero)
+ (immediate
+ (let ((value (ash (logand (tn-value value) ,(1- (ash 1 bits)))
+ (* extra ,bits))))
+ (cond ((< value #x10000)
+ (inst bis old value old))
+ (t
+ (inst li value temp)
+ (inst bis old temp old)))))
+ (unsigned-reg
+ (inst sll value (* extra ,bits) temp)
+ (inst bis old temp old)))
+ (inst stl old
+ (- (* (+ word vector-data-offset) word-bytes)
+ other-pointer-type)
+ object)
+ (sc-case value
+ (immediate
+ (inst li (tn-value value) result))
+ (zero
+ (move zero-tn result))
+ (unsigned-reg
+ (move value result))))))))))
+ (def-full-data-vector-frobs simple-vector *
+ descriptor-reg any-reg null zero)
+
+ (def-partial-data-vector-frobs simple-string base-char :byte nil
+ base-char-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
+ :byte nil unsigned-reg signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
+ :short nil unsigned-reg signed-reg)
+
+ (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+ unsigned-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
+ :byte t signed-reg)
+
+ (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
+ :short t signed-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+
+ (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num signed-reg)
+
+ ;; Integer vectors whos elements are smaller than a byte. I.e. bit, 2-bit,
+ ;; and 4-bit vectors.
+ ;;
+
+ (def-small-data-vector-frobs simple-bit-vector 1)
+ (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+ (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
+
+
+;;; And the float variants.
+;;;
+
+(define-vop (data-vector-ref/simple-array-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-single-float positive-fixnum)
+ (:results (value :scs (single-reg)))
+ (:result-types single-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst addq object index lip)
+ (inst lds value
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)))
+
+(define-vop (data-vector-set/simple-array-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
+ (:arg-types simple-array-single-float positive-fixnum single-float)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst addq object index lip)
+ (inst sts value
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)
+ (unless (location= result value)
+ (inst fmove value result))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-double-float positive-fixnum)
+ (:results (value :scs (double-reg)))
+ (:result-types double-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst ldt value
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type)
+ lip)))
+
+(define-vop (data-vector-set/simple-array-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
+ (:arg-types simple-array-double-float positive-fixnum double-float)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst stt value
+ (- (* vector-data-offset word-bytes)
+ other-pointer-type) lip)
+ (unless (location= result value)
+ (inst fmove value result))))
+
+\f
+;;; Complex float arrays.
+
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-single-float positive-fixnum)
+ (:results (value :scs (complex-single-reg)))
+ (:temporary (:scs (interior-reg)) lip)
+ (:result-types complex-single-float)
+ (:generator 5
+ (let ((real-tn (complex-single-reg-real-tn value)))
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst lds real-tn
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ lip))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (inst lds imag-tn
+ (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+ lip))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
+ (:arg-types simple-array-complex-single-float positive-fixnum
+ complex-single-float)
+ (:results (result :scs (complex-single-reg)))
+ (:result-types complex-single-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 5
+ (let ((value-real (complex-single-reg-real-tn value))
+ (result-real (complex-single-reg-real-tn result)))
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst sts value-real
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ lip)
+ (unless (location= result-real value-real)
+ (inst fmove value-real result-real)))
+ (let ((value-imag (complex-single-reg-imag-tn value))
+ (result-imag (complex-single-reg-imag-tn result)))
+ (inst sts value-imag
+ (- (* (1+ vector-data-offset) word-bytes) other-pointer-type)
+ lip)
+ (unless (location= result-imag value-imag)
+ (inst fmove value-imag result-imag)))))
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-double-float positive-fixnum)
+ (:results (value :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 7
+ (let ((real-tn (complex-double-reg-real-tn value)))
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst addq lip index lip)
+ (inst addq lip index lip)
+ (inst ldt real-tn
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ lip))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (inst ldt imag-tn
+ (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+ lip))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
+ (:arg-types simple-array-complex-double-float positive-fixnum
+ complex-double-float)
+ (:results (result :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:temporary (:scs (interior-reg)) lip)
+ (:generator 20
+ (let ((value-real (complex-double-reg-real-tn value))
+ (result-real (complex-double-reg-real-tn result)))
+ (inst addq object index lip)
+ (inst addq lip index lip)
+ (inst addq lip index lip)
+ (inst addq lip index lip)
+ (inst stt value-real
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ lip)
+ (unless (location= result-real value-real)
+ (inst fmove value-real result-real)))
+ (let ((value-imag (complex-double-reg-imag-tn value))
+ (result-imag (complex-double-reg-imag-tn result)))
+ (inst stt value-imag
+ (- (* (+ vector-data-offset 2) word-bytes) other-pointer-type)
+ lip)
+ (unless (location= result-imag value-imag)
+ (inst fmove value-imag result-imag)))))
+
+\f
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector.
+;;;
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+ (:translate %raw-ref-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+ (:translate %raw-set-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+;;;
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+ (:translate %raw-ref-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+ (:translate %raw-set-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+
+(define-vop (raw-ref-complex-single
+ data-vector-ref/simple-array-complex-single-float)
+ (:translate %raw-ref-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-complex-single
+ data-vector-set/simple-array-complex-single-float)
+ (:translate %raw-set-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+ complex-single-float))
+;;;
+(define-vop (raw-ref-complex-double
+ data-vector-ref/simple-array-complex-double-float)
+ (:translate %raw-ref-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+;;;
+(define-vop (raw-set-complex-double
+ data-vector-set/simple-array-complex-double-float)
+ (:translate %raw-set-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+ complex-double-float))
+
+
+;;; These vops are useful for accessing the bits of a vector irrespective of
+;;; what type of vector it is.
+;;;
+
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg) unsigned-num
+ %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+ unsigned-num %set-raw-bits #+gengc nil)
+
+
+\f
+;;;; Misc. Array VOPs.
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
--- /dev/null
+;;;; that part of the parms.lisp file from original CMU CL which is defined in
+;;;; terms of the BACKEND structure
+;;;;
+;;;; FIXME: When we break up the BACKEND structure, this might be mergeable
+;;;; back into the parms.lisp file.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+
+
+(in-package "SB!VM")
+
+\f
+;;;; compiler constants
+
+(setf *backend-fasl-file-type* "axpf")
+(setf *backend-fasl-file-implementation* :alpha)
+(setf *backend-fasl-file-version* 2)
+;;;(setf *backend-fasl-file-version* 8)
+;;; 8 = sbcl-0.6.10.4 revived Gray stream support, changing stream layouts
+
+
+(setf *backend-register-save-penalty* 3)
+
+(setf *backend-byte-order* :little-endian)
+
+;;; XXX the C runtime gets page size using getpagesize() - can't we
+;;; look at that instead of hardcoding it here too?
+(setf *backend-page-size* 8192)
+
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and other necessary machine specific support
+;;; routines for call-out to C.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+(use-package "SB!ALIEN")
+(use-package "SB!ALIEN-INTERNALS")
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+ (make-wired-tn (primitive-type-or-lose prim-type-name )
+ (sc-number-or-lose sc-name )
+ offset))
+
+(defstruct arg-state
+ (stack-frame-size 0))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (multiple-value-bind
+ (ptype reg-sc stack-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-64 'signed-reg 'signed-stack)
+ (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack))
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset))
+ (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4)))))))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (if (< stack-frame-size 4)
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-reg
+ (+ stack-frame-size nl0-offset))
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-stack
+ (* 2 (- stack-frame-size 4))))))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (if (< stack-frame-size 6)
+ (my-make-wired-tn 'double-float
+ 'double-reg
+ (+ stack-frame-size nl0-offset))
+ (my-make-wired-tn 'double-float
+ 'double-stack
+ (* 2 (- stack-frame-size 6))))))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (if (< stack-frame-size 6)
+ (my-make-wired-tn 'single-float
+ 'single-reg
+ (+ stack-frame-size nl0-offset))
+ (my-make-wired-tn 'single-float
+ 'single-stack
+ (* 2 (- stack-frame-size 6))))))
+
+
+
+(def-alien-type-method (integer :result-tn) (type state)
+ (declare (ignore state))
+ (multiple-value-bind
+ (ptype reg-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-64 'signed-reg)
+ (values 'unsigned-byte-64 'unsigned-reg))
+ (my-make-wired-tn ptype reg-sc lip-offset)))
+
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+ (declare (ignore type state))
+ (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
+
+(def-alien-type-method (double-float :result-tn) (type state)
+ (declare (ignore type state))
+ (my-make-wired-tn 'double-float 'double-reg lip-offset))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+ (declare (ignore type state))
+ (my-make-wired-tn 'single-float 'single-reg lip-offset))
+
+(def-alien-type-method (values :result-tn) (type state)
+ (let ((values (alien-values-type-values type)))
+ (when (cdr values)
+ (error "Too many result values from c-call."))
+ (when values
+ (invoke-alien-type-method :result-tn (car values) state))))
+
+(!def-vm-support-routine make-call-out-tns (type)
+ (let ((arg-state (make-arg-state)))
+ (collect ((arg-tns))
+ (dolist (arg-type (alien-function-type-arg-types type))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
+ (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-function-type-result-type type)
+ nil)))))
+
+
+(define-vop (foreign-symbol-address)
+ (:translate foreign-symbol-address)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst li (make-fixup foreign-symbol :foreign) res)))
+
+(define-vop (call-out)
+ (:args (function :scs (sap-reg) :target cfunc)
+ (args :more t))
+ (:results (results :more t))
+ (:ignore args results)
+ (:save-p t)
+ (:temporary (:sc any-reg :offset cfunc-offset
+ :from (:argument 0) :to (:result 0)) cfunc)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:vop-var vop)
+ (:generator 0
+ (let ((cur-nfp (sb!c::current-nfp-tn vop)))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (move function cfunc)
+ (inst li (make-fixup "call_into_c" :foreign) temp)
+ (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
+ (when cur-nfp
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
+
+(define-vop (alloc-number-stack-space)
+ (:info amount)
+ (:results (result :scs (sap-reg any-reg)))
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:generator 0
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 7) 7)))
+ (cond ((< delta (ash 1 15))
+ (inst lda nsp-tn (- delta) nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst subq nsp-tn temp nsp-tn)))))
+ (move nsp-tn result)))
+
+(define-vop (dealloc-number-stack-space)
+ (:info amount)
+ (:policy :fast-safe)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
+ (:generator 0
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 7) 7)))
+ (cond ((< delta (ash 1 15))
+ (inst lda nsp-tn delta nsp-tn))
+ (t
+ (inst li delta temp)
+ (inst addq nsp-tn temp nsp-tn)))))))
--- /dev/null
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of function call for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted for the Alpha by Sean Hallgren
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; Interfaces to IR2 conversion:
+
+;;; Standard-Argument-Location -- Interface
+;;;
+;;; Return a wired TN describing the N'th full call argument passing
+;;; location.
+;;;
+(!def-vm-support-routine standard-argument-location (n)
+ (declare (type unsigned-byte n))
+ (if (< n register-arg-count)
+ (make-wired-tn *backend-t-primitive-type*
+ register-arg-scn
+ (elt *register-arg-offsets* n))
+ (make-wired-tn *backend-t-primitive-type*
+ control-stack-arg-scn n)))
+
+
+;;; Make-Return-PC-Passing-Location -- Interface
+;;;
+;;; Make a passing location TN for a local call return PC. If standard is
+;;; true, then use the standard (full call) location, otherwise use any legal
+;;; location. Even in the non-standard case, this may be restricted by a
+;;; desire to use a subroutine call instruction.
+;;;
+(!def-vm-support-routine make-return-pc-passing-location (standard)
+ #!+gengc (declare (ignore standard))
+ #!-gengc
+ (if standard
+ (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
+ (make-restricted-tn *backend-t-primitive-type* register-arg-scn))
+ #!+gengc
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ra-offset))
+
+;;; Make-Old-FP-Passing-Location -- Interface
+;;;
+;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in. This is (obviously) wired in the standard convention, but is
+;;; totally unrestricted in non-standard conventions, since we can always fetch
+;;; it off of the stack using the arg pointer.
+;;;
+(!def-vm-support-routine make-old-fp-passing-location (standard)
+ (if standard
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make-Old-FP-Save-Location, Make-Return-PC-Save-Location -- Interface
+;;;
+;;; Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function. We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+(!def-vm-support-routine make-old-fp-save-location (env)
+ (specify-save-tn
+ (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+ (make-wired-tn *fixnum-primitive-type*
+ control-stack-arg-scn
+ ocfp-save-offset)))
+;;;
+(!def-vm-support-routine make-return-pc-save-location (env)
+ (let ((ptype #!-gengc *backend-t-primitive-type*
+ #!+gengc *fixnum-primitive-type*))
+ (specify-save-tn
+ (environment-debug-live-tn (make-normal-tn ptype) env)
+ (make-wired-tn ptype control-stack-arg-scn
+ #!-gengc lra-save-offset #!+gengc ra-save-offset))))
+
+;;; Make-Argument-Count-Location -- Interface
+;;;
+;;; Make a TN for the standard argument count passing location. We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+;;;
+(!def-vm-support-routine make-argument-count-location ()
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nargs-offset))
+
+
+;;; MAKE-NFP-TN -- Interface
+;;;
+;;; Make a TN to hold the number-stack frame pointer. This is allocated
+;;; once per component, and is component-live.
+;;;
+(!def-vm-support-routine make-nfp-tn ()
+ (component-live-tn
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))
+
+;;; MAKE-STACK-POINTER-TN ()
+;;;
+(!def-vm-support-routine make-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; MAKE-NUMBER-STACK-POINTER-TN ()
+;;;
+(!def-vm-support-routine make-number-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+;;; Make-Unknown-Values-Locations -- Interface
+;;;
+;;; Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+;;;
+(!def-vm-support-routine make-unknown-values-locations ()
+ (list (make-stack-pointer-tn)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; Select-Component-Format -- Interface
+;;;
+;;; This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure. We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+(!def-vm-support-routine select-component-format (component)
+ (declare (type component component))
+ (dotimes (i code-constants-offset)
+ (vector-push-extend nil
+ (ir2-component-constants (component-info component))))
+ (values))
+
+\f
+;;;; Frame hackery:
+
+;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
+;;;
+;;; Return the number of bytes needed for the current non-descriptor stack
+;;; frame. Non-descriptor stack frames must be multiples of 8 bytes on
+;;; the PMAX.
+;;;
+(defun bytes-needed-for-non-descriptor-stack-frame ()
+ (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
+ word-bytes))
+
+;;; Used for setting up the Old-FP in local call.
+;;;
+(define-vop (current-fp)
+ (:results (val :scs (any-reg)))
+ (:generator 1
+ (move cfp-tn val)))
+
+;;; Used for computing the caller's NFP for use in known-values return. Only
+;;; works assuming there is no variable size stuff on the nstack.
+;;;
+(define-vop (compute-old-nfp)
+ (:results (val :scs (any-reg)))
+ (:vop-var vop)
+ (:generator 1
+ (let ((nfp (current-nfp-tn vop)))
+ (when nfp
+ (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))
+
+
+(define-vop (xep-allocate-frame)
+ (:info start-lab copy-more-arg-follows)
+ (:ignore copy-more-arg-follows)
+ (:vop-var vop)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 1
+ ;; Make sure the function is aligned, and drop a label pointing to this
+ ;; function header.
+ (align lowtag-bits)
+ (trace-table-entry trace-table-function-prologue)
+ (emit-label start-lab)
+ ;; Allocate function header.
+ (inst function-header-word)
+ (dotimes (i (1- function-code-offset))
+ (inst lword 0))
+ ;; The start of the actual code.
+ ;; Compute CODE from the address of this entry point.
+ (let ((entry-point (gen-label)))
+ (emit-label entry-point)
+ (inst compute-code-from-fn code-tn lip-tn entry-point temp)
+ ;; ### We should also save it on the stack so that the garbage collector
+ ;; won't forget about us if we call anyone else.
+ )
+ ;; Build our stack frames.
+ (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) cfp-tn)
+ (let ((nfp (current-nfp-tn vop)))
+ (when nfp
+ (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)
+ (move nsp-tn nfp)))
+ (trace-table-entry trace-table-normal)))
+
+(define-vop (allocate-frame)
+ (:results (res :scs (any-reg))
+ (nfp :scs (any-reg)))
+ (:info callee)
+ (:generator 2
+ (trace-table-entry trace-table-function-prologue)
+ (move csp-tn res)
+ (inst lda csp-tn (* word-bytes (sb-allocated-size 'control-stack)) csp-tn)
+ (when (ir2-environment-number-stack-p callee)
+ (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)
+ (move nsp-tn nfp))
+ (trace-table-entry trace-table-normal)))
+
+;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
+;;; is the number of arguments passed. If no stack arguments are passed, then
+;;; we don't have to do anything.
+;;;
+(define-vop (allocate-full-call-frame)
+ (:info nargs)
+ (:results (res :scs (any-reg)))
+ (:generator 2
+ (when (> nargs register-arg-count)
+ (move csp-tn res)
+ (inst lda csp-tn (* nargs word-bytes) csp-tn))))
+
+
+\f
+;;; Default-Unknown-Values -- Internal
+;;;
+;;; Emit code needed at the return-point from an unknown-values call for a
+;;; fixed number of values. Values is the head of the TN-Ref list for the
+;;; locations that the values are to be received into. Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;; Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;; This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 8, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;; If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case, we have to do three things:
+;;; -- Default unsupplied register values. This need only be done when a
+;;; single value is returned, since register values are defaulted by the
+;;; called in the non-single case.
+;;; -- Default unsupplied stack values. This needs to be done whenever there
+;;; are stack values.
+;;; -- Reset SP. This must be done whenever other than 1 value is returned,
+;;; regardless of the number of values desired.
+;;;
+;;; The general-case code looks like this:
+#|
+ b regs-defaulted ; Skip if MVs
+ nop
+
+ move a1 null-tn ; Default register values
+ ...
+ loadi nargs 1 ; Force defaulting of stack values
+ move ocfp csp ; Set up args for SP resetting
+
+regs-defaulted
+ subu temp nargs register-arg-count
+
+ bltz temp default-value-7 ; jump to default code
+ addu temp temp -1
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
+
+ bltz temp default-value-8
+ addu temp temp -1
+ loadw move-temp ocfp-tn 7
+ store-stack-tn val5-tn move-temp
+
+ ...
+
+defaulting-done
+ move sp ocfp ; Reset SP.
+<end of code>
+
+<elsewhere>
+default-value-7
+ store-stack-tn val4-tn null-tn ; Nil out 7'th value. (first on stack)
+
+default-value-8
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
+
+ ...
+
+ br defaulting-done
+ nop
+|#
+;;;
+(defun default-unknown-values (vop values nvals move-temp temp lra-label)
+ (declare (type (or tn-ref null) values)
+ (type unsigned-byte nvals) (type tn move-temp temp))
+ (if (<= nvals 1)
+ (progn
+ ;; Note that this is a single-value return point. This is actually
+ ;; the multiple-value entry point for a single desired value, but
+ ;; the code location has to be here, or the debugger backtrace
+ ;; gets confused.
+ (without-scheduling ()
+ (note-this-location vop :single-value-return)
+ (move ocfp-tn csp-tn)
+ (inst nop))
+ (when lra-label
+ #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp)))
+ (let ((regs-defaulted (gen-label))
+ (defaulting-done (gen-label))
+ (default-stack-vals (gen-label)))
+ (without-scheduling ()
+ ;; Note that this is an unknown-values return point.
+ (note-this-location vop :unknown-return)
+ ;; If there are no stack results, clear the stack now.
+ (if (> nvals register-arg-count)
+ (inst subq nargs-tn (fixnumize register-arg-count) temp)
+ (move ocfp-tn csp-tn))
+ ;; Branch off to the MV case.
+ (inst br zero-tn regs-defaulted))
+
+ ;; Do the single value case.
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (move null-tn (tn-ref-tn val)))
+ (when (> nvals register-arg-count)
+ (move csp-tn ocfp-tn)
+ (inst br zero-tn default-stack-vals))
+
+ (emit-label regs-defaulted)
+
+ (when (> nvals register-arg-count)
+ ;; If there are stack results, we have to default them
+ ;; and clear the stack.
+ (collect ((defaults))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst blt temp default-lab)
+ (inst ldl move-temp (* i word-bytes) ocfp-tn)
+ (inst subq temp (fixnumize 1) temp)
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move ocfp-tn csp-tn)
+
+ (let ((defaults (defaults)))
+ (assert defaults)
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (when (null (cdr remaining))
+ (inst br zero-tn defaulting-done))
+ (store-stack-tn (cdr def) null-tn)))))))
+
+ (when lra-label
+ #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))))
+ (values))
+
+\f
+;;;; Unknown values receiving:
+
+;;; Receive-Unknown-Values -- Internal
+;;;
+;;; Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;; We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;; When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;; When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;; Args and Nargs are TNs wired to the named locations. We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+;;;
+(defun receive-unknown-values (args nargs start count lra-label temp)
+ (declare (type tn args nargs start count temp))
+ (let ((variable-values (gen-label))
+ (done (gen-label)))
+ (without-scheduling ()
+ (inst br zero-tn variable-values)
+ (inst nop))
+
+ (when lra-label
+ #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+ (inst addq csp-tn 4 csp-tn)
+ (storew (first *register-arg-tns*) csp-tn -1)
+ (inst subq csp-tn 4 start)
+ (inst li (fixnumize 1) count)
+
+ (emit-label done)
+
+ (assemble (*elsewhere*)
+ (emit-label variable-values)
+ (when lra-label
+ #!-gengc (inst compute-code-from-lra code-tn code-tn lra-label temp)
+ #!+gengc (inst compute-code-from-ra code-tn ra-tn lra-label temp))
+ (do ((arg *register-arg-tns* (rest arg))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
+ (move args start)
+ (move nargs count)
+ (inst br zero-tn done)))
+ (values))
+
+
+;;; VOP that can be inherited by unknown values receivers. The main thing this
+;;; handles is allocation of the result temporaries.
+;;;
+(define-vop (unknown-values-receiver)
+ (:results
+ (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:temporary (:sc descriptor-reg :offset ocfp-offset
+ :from :eval :to (:result 0))
+ values-start)
+ (:temporary (:sc any-reg :offset nargs-offset
+ :from :eval :to (:result 1))
+ nvals)
+ (:temporary (:scs (non-descriptor-reg)) temp))
+
+
+\f
+;;;; Local call with unknown values convention return:
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;; Return-PC is the TN that the return PC should be passed in.
+;;; Target is a continuation pointing to the start of the called function.
+;;; Nvals is the number of values received.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand. Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (call-local)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:results (values :more t))
+ (:save-p t)
+ (:move-args :local-call)
+ (:info arg-locs callee target nvals)
+ (:vop-var vop)
+ (:temporary (:scs (descriptor-reg) :from :eval) move-temp)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:sc any-reg :offset ocfp-offset :from :eval) ocfp)
+ (:ignore arg-locs args ocfp)
+ (:generator 5
+ (let ((label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (let ((callee-nfp (callee-nfp-tn callee)))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-tn cfp-tn fp)
+ (trace-table-entry trace-table-call-site)
+ (inst compute-lra-from-code
+ (callee-return-pc-tn callee) code-tn label temp)
+ (note-this-location vop :call-site)
+ (inst br zero-tn target)
+ (trace-table-entry trace-table-normal)
+ (emit-return-pc label)
+ (default-unknown-values vop values nvals move-temp temp label)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention. The results are the start of the values
+;;; glob and the number of values received.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand. Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (multiple-call-local unknown-values-receiver)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:save-p t)
+ (:move-args :local-call)
+ (:info save callee target)
+ (:ignore args save)
+ (:vop-var vop)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 20
+ (let ((label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (let ((callee-nfp (callee-nfp-tn callee)))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-tn cfp-tn fp)
+ (trace-table-entry trace-table-call-site)
+ (inst compute-lra-from-code
+ (callee-return-pc-tn callee) code-tn label temp)
+ (note-this-location vop :call-site)
+ (inst bsr zero-tn target)
+ (trace-table-entry trace-table-normal)
+ (emit-return-pc label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count label temp)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+\f
+;;;; Local call with known values return:
+
+;;; Non-TR local call with known return locations. Known-value return works
+;;; just like argument passing in local call.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand. Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-call-local)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:results (res :more t))
+ (:move-args :local-call)
+ (:save-p t)
+ (:info save callee target)
+ (:ignore args res save)
+ (:vop-var vop)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 5
+ (let (#!-gengc (label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (let ((callee-nfp (callee-nfp-tn callee)))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-tn cfp-tn fp)
+ (trace-table-entry trace-table-call-site)
+ (inst compute-lra-from-code
+ (callee-return-pc-tn callee) code-tn label temp)
+ (note-this-location vop :call-site)
+ (inst bsr zero-tn target)
+ (trace-table-entry trace-table-normal)
+ (emit-return-pc label)
+ (note-this-location vop :known-return)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))))
+
+;;; Return from known values call. We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function. We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand. Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+;;;
+(define-vop (known-return)
+ (:args (ocfp :target ocfp-temp)
+ (return-pc :target return-pc-temp)
+ (vals :more t))
+ (:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
+ (:temporary (:sc #!-gengc descriptor-reg #!+gengc any-reg :from (:argument 1))
+ return-pc-temp)
+ #!-gengc (:temporary (:scs (interior-reg)) lip)
+ (:move-args :known-return)
+ (:info val-locs)
+ (:ignore val-locs vals)
+ (:vop-var vop)
+ (:generator 6
+ (trace-table-entry trace-table-function-epilogue)
+ (maybe-load-stack-tn ocfp-temp ocfp)
+ (maybe-load-stack-tn return-pc-temp return-pc)
+ (move cfp-tn csp-tn)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+ (inst subq return-pc-temp (- other-pointer-type word-bytes) lip)
+ (move ocfp-temp cfp-tn)
+ (inst ret zero-tn lip 1)
+ (trace-table-entry trace-table-normal)))
+
+\f
+;;;; Full call:
+;;;
+;;; There is something of a cross-product effect with full calls. Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame. On entry to the
+;;; callee, this partial frame is pointed to by FP. If there are no stack
+;;; arguments, we don't bother allocating a partial frame, and instead set FP
+;;; to SP just before the call.
+
+;;; Define-Full-Call -- Internal
+;;;
+;;; This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;;
+;;; Named is true if the first argument is a symbol whose global function
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;; the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;; result values are specified by the Start and Count as in the
+;;; unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call. No values are returned.
+;;; The Ocfp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument. If Variable is false, then the passing locations are
+;;; passed as a more arg. Variable is true if there are a variable number of
+;;; arguments passed on the stack. Variable cannot be specified with :Tail
+;;; return. TR variable argument call is implemented separately.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+;;;
+(defmacro define-full-call (name named return variable)
+ (assert (not (and variable (eq return :tail))))
+ `(define-vop (,name
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
+ (:args
+ ,@(unless (eq return :tail)
+ '((new-fp :scs (any-reg) :to :eval)))
+
+ ,(if named
+ '(name :target name-pass)
+ '(arg-fun :target lexenv))
+
+ ,@(when (eq return :tail)
+ '((ocfp :target ocfp-pass)
+ (return-pc :target return-pc-pass)))
+
+ ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+ ,@(when (eq return :fixed)
+ '((:results (values :more t))))
+
+ (:save-p ,(if (eq return :tail) :compute-only t))
+
+ ,@(unless (or (eq return :tail) variable)
+ '((:move-args :full-call)))
+
+ (:vop-var vop)
+ (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
+
+ (:ignore #!+gengc ,@(unless (eq return :tail) '(return-pc-pass))
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
+
+ (:temporary (:sc descriptor-reg
+ :offset ocfp-offset
+ :from (:argument 1)
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ ocfp-pass)
+
+ (:temporary (:sc descriptor-reg
+ :offset #!-gengc lra-offset #!+gengc ra-offset
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ return-pc-pass)
+
+ ,@(if named
+ `((:temporary (:sc descriptor-reg :offset fdefn-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ name-pass))
+
+ `((:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv)
+ #!-gengc
+ (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+ function)))
+
+ (:temporary (:sc any-reg :offset nargs-offset :to :eval)
+ nargs-pass)
+
+ ,@(when variable
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
+ ,@(when (eq return :fixed)
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+
+ ,@(unless (eq return :tail)
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+
+ (:temporary (:sc interior-reg :offset lip-offset) entry-point)
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (let* ((cur-nfp (current-nfp-tn vop))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(#!-gengc
+ :comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst subq csp-tn new-fp nargs-pass)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (name)
+ `(inst ldl ,name
+ ,(ash (incf index)
+ word-shift)
+ new-fp))
+ register-arg-names)))
+ '((inst li (fixnumize nargs) nargs-pass))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (inst move ocfp ocfp-pass))
+ (control-stack
+ (inst ldl ocfp-pass
+ (ash (tn-offset ocfp)
+ word-shift)
+ cfp-tn))))
+ (:load-return-pc
+ (sc-case return-pc
+ (#!-gengc descriptor-reg #!+gengc any-reg
+ (inst move return-pc return-pc-pass))
+ (control-stack
+ (inst ldl return-pc-pass
+ (ash (tn-offset return-pc)
+ word-shift)
+ cfp-tn))))
+ (:frob-nfp
+ (inst addq cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+ `(#!-gengc
+ (:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (inst move cfp-tn ocfp-pass))
+ (:load-fp
+ ,(if variable
+ '(move new-fp cfp-tn)
+ '(if (> nargs register-arg-count)
+ (move new-fp cfp-tn)
+ (move csp-tn cfp-tn)))
+ (trace-table-entry trace-table-call-site))))
+ ((nil))))))
+
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name name-pass))
+ (control-stack
+ (inst ldl name-pass
+ (ash (tn-offset name) word-shift) cfp-tn)
+ (do-next-filler))
+ (constant
+ (inst ldl name-pass
+ (- (ash (tn-offset name) word-shift)
+ other-pointer-type) code-tn)
+ (do-next-filler)))
+ (inst ldl entry-point
+ (- (ash fdefn-raw-addr-slot word-shift)
+ other-pointer-type) name-pass)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move arg-fun lexenv))
+ (control-stack
+ (inst ldl lexenv
+ (ash (tn-offset arg-fun) word-shift) cfp-tn)
+ (do-next-filler))
+ (constant
+ (inst ldl lexenv
+ (- (ash (tn-offset arg-fun) word-shift)
+ other-pointer-type) code-tn)
+ (do-next-filler)))
+ #!-gengc
+ (inst ldl function
+ (- (ash closure-function-slot word-shift)
+ function-pointer-type) lexenv)
+ #!-gengc
+ (do-next-filler)
+ #!-gengc
+ (inst addq function
+ (- (ash function-code-offset word-shift)
+ function-pointer-type) entry-point)
+ #!+gengc
+ (inst ldl entry-point
+ (- (ash closure-entry-point-slot word-shift)
+ function-pointer-type) lexenv)
+ #!+gengc
+ (do-next-filler)))
+ (loop
+ (if (cdr filler)
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (do-next-filler)
+ (inst jsr zero-tn entry-point))
+
+ ,@(ecase return
+ (:fixed
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (default-unknown-values vop values nvals
+ move-temp temp lra-label)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+ (:unknown
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+ (:tail))))))
+
+
+(define-full-call call nil :fixed nil)
+(define-full-call call-named t :fixed nil)
+(define-full-call multiple-call nil :unknown nil)
+(define-full-call multiple-call-named t :unknown nil)
+(define-full-call tail-call nil :tail nil)
+(define-full-call tail-call-named t :tail nil)
+
+(define-full-call call-variable nil :fixed t)
+(define-full-call multiple-call-variable nil :unknown t)
+
+
+;;; Defined separately, since needs special code that BLT's the arguments
+;;; down.
+;;;
+(define-vop (tail-call-variable)
+ (:args
+ (args-arg :scs (any-reg) :target args)
+ (function-arg :scs (descriptor-reg) :target lexenv)
+ (ocfp-arg :scs (any-reg) :target ocfp)
+ (lra-arg :scs (#!-gengc descriptor-reg #!+gengc any-reg) :target lra))
+
+ (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
+ (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
+ (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp)
+ (:temporary (:sc any-reg :offset #!-gengc lra-offset #!+gengc ra-offset
+ :from (:argument 3)) lra)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+
+ (:vop-var vop)
+
+ (:generator 75
+
+ ;; Move these into the passing locations if they are not already there.
+ (move args-arg args)
+ (move function-arg lexenv)
+ (move ocfp-arg ocfp)
+ (move lra-arg lra)
+
+ ;; Clear the number stack if anything is there.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+
+ ;; And jump to the assembly-routine that does the bliting.
+ (inst li (make-fixup 'tail-call-variable :assembly-routine) temp)
+ (inst jmp zero-tn temp)))
+
+\f
+;;;; Unknown values return:
+
+;;; Return a single value using the unknown-values convention.
+;;;
+(define-vop (return-single)
+ (:args (ocfp :scs (any-reg))
+ #!-gengc (return-pc :scs (descriptor-reg))
+ #!+gengc (return-pc :scs (any-reg) :target ra)
+ (value))
+ (:ignore value)
+ #!-gengc (:temporary (:scs (interior-reg)) lip)
+ #!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
+ #!+gengc (:temporary (:scs (any-reg) :from (:argument 1)) temp)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-function-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+ ;; Clear the control stack, and restore the frame pointer.
+ (move cfp-tn csp-tn)
+ (move ocfp cfp-tn)
+ ;; Out of here.
+ #!-gengc (lisp-return return-pc lip :offset 2)
+ #!+gengc
+ (progn
+ (inst addq return-pc (* 2 word-bytes) temp)
+ (unless (location= ra return-pc)
+ (inst move ra return-pc))
+ (inst ret zero-tn temp 1))
+ (trace-table-entry trace-table-normal)))
+
+
+;;; Do unknown-values return of a fixed number of values. The Values are
+;;; required to be set up in the standard passing locations. Nvals is the
+;;; number of values returned.
+;;;
+;;; If returning a single value, then deallocate the current frame, restore
+;;; FP and jump to the single-value entry at Return-PC + 8.
+;;;
+;;; If returning other than one value, then load the number of values returned,
+;;; NIL out unsupplied values registers, restore FP and return at Return-PC.
+;;; When there are stack values, we must initialize the argument pointer to
+;;; point to the beginning of the values block (which is the beginning of the
+;;; current frame.)
+;;;
+(define-vop (return)
+ (:args (ocfp :scs (any-reg))
+ (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg) :to (:eval 1)
+ #!+gengc :target #!+gengc ra)
+ (values :more t))
+ (:ignore values)
+ (:info nvals)
+ (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
+ (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
+ (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
+ (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+ (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)
+ (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
+ (:temporary (:sc any-reg :offset nargs-offset) nargs)
+ (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
+ #!-gengc (:temporary (:scs (interior-reg)) lip)
+ #!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 1)) ra)
+ (:vop-var vop)
+ (:generator 6
+ ;; Clear the number stack.
+ (trace-table-entry trace-table-function-epilogue)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+ ;; Establish the values pointer and values count.
+ (move cfp-tn val-ptr)
+ (inst li (fixnumize nvals) nargs)
+ ;; restore the frame pointer and clear as much of the control
+ ;; stack as possible.
+ (move ocfp cfp-tn)
+ (inst addq val-ptr (* nvals word-bytes) csp-tn)
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
+ (move null-tn reg)))
+ ;; And away we go.
+ (lisp-return return-pc lip)
+ (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.) We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention. Otherwise, we
+;;; branch off to code that calls an assembly-routine.
+;;;
+(define-vop (return-multiple)
+ (:args (ocfp-arg :scs (any-reg) :target ocfp)
+ #!-gengc (lra-arg :scs (descriptor-reg) :target lra)
+ #!+gengc (return-pc :scs (any-reg) :target ra)
+ (vals-arg :scs (any-reg) :target vals)
+ (nvals-arg :scs (any-reg) :target nvals))
+
+ (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
+ #!-gengc
+ (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
+ #!+gengc
+ (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
+ (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
+ (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
+ (:temporary (:sc descriptor-reg :offset a0-offset) a0)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ #!-gengc (:temporary (:scs (interior-reg)) lip)
+ #!+gengc (:temporary (:scs (any-reg) :from (:argument 0)) temp)
+
+ (:vop-var vop)
+
+ (:generator 13
+ (trace-table-entry trace-table-function-epilogue)
+ (let ((not-single (gen-label)))
+ ;; Clear the number stack.
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+
+ ;; Check for the single case.
+ (inst li (fixnumize 1) a0)
+ (inst cmpeq nvals-arg a0 temp)
+ (inst ldl a0 0 vals-arg)
+ (inst beq temp not-single)
+
+ ;; Return with one value.
+ (move cfp-tn csp-tn)
+ (move ocfp-arg cfp-tn)
+ (lisp-return lra-arg lip :offset 2)
+
+ ;; Nope, not the single case.
+ (emit-label not-single)
+ (move ocfp-arg ocfp)
+ (move lra-arg lra)
+ (move vals-arg vals)
+ (move nvals-arg nvals)
+ (inst li (make-fixup 'return-multiple :assembly-routine) temp)
+ (inst jmp zero-tn temp))
+ (trace-table-entry trace-table-normal)))
+
+
+\f
+;;;; XEP hackery:
+
+
+;;; We don't need to do anything special for regular functions.
+;;;
+(define-vop (setup-environment)
+ (:info label)
+ (:ignore label)
+ (:generator 0
+ ;; Don't bother doing anything.
+ ))
+
+;;; Get the lexical environment from its passing location.
+;;;
+(define-vop (setup-closure-environment)
+ (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
+ :to (:result 0))
+ lexenv)
+ (:results (closure :scs (descriptor-reg)))
+ (:info label)
+ (:ignore label)
+ (:generator 6
+ ;; Get result.
+ (move lexenv closure)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments.
+;;;
+(define-vop (copy-more-arg)
+ (:temporary (:sc any-reg :offset nl0-offset) result)
+ (:temporary (:sc any-reg :offset nl1-offset) count)
+ (:temporary (:sc any-reg :offset nl2-offset) src)
+ (:temporary (:sc any-reg :offset nl4-offset) dst)
+ (:temporary (:sc descriptor-reg :offset l0-offset) temp)
+ (:info fixed)
+ (:generator 20
+ (let ((loop (gen-label))
+ (do-regs (gen-label))
+ (done (gen-label)))
+ (when (< fixed register-arg-count)
+ ;; Save a pointer to the results so we can fill in register args.
+ ;; We don't need this if there are more fixed args than reg args.
+ (move csp-tn result))
+ ;; Allocate the space on the stack.
+ (cond ((zerop fixed)
+ (inst addq csp-tn nargs-tn csp-tn)
+ (inst beq nargs-tn done))
+ (t
+ (inst subq nargs-tn (fixnumize fixed) count)
+ (inst ble count done)
+ (inst addq csp-tn count csp-tn)))
+ (when (< fixed register-arg-count)
+ ;; We must stop when we run out of stack args, not when we run out of
+ ;; more args.
+ (inst subq nargs-tn (fixnumize register-arg-count) count))
+ ;; Initialize dst to be end of stack.
+ (move csp-tn dst)
+ ;; Everything of interest in registers.
+ (inst ble count do-regs)
+ ;; Initialize src to be end of args.
+ (inst addq cfp-tn nargs-tn src)
+
+ (emit-label loop)
+ ;; *--dst = *--src, --count
+ (inst subq src word-bytes src)
+ (inst subq count (fixnumize 1) count)
+ (loadw temp src)
+ (inst subq dst word-bytes dst)
+ (storew temp dst)
+ (inst bgt count loop)
+
+ (emit-label do-regs)
+ (when (< fixed register-arg-count)
+ ;; Now we have to deposit any more args that showed up in registers.
+ ;; We know there is at least one more arg, otherwise we would have
+ ;; branched to done up at the top.
+ (inst subq nargs-tn (fixnumize (1+ fixed)) count)
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i *register-arg-tns*) result (- i fixed))
+ ;; Is this the last one?
+ (inst beq count done)
+ ;; Decrement count.
+ (inst subq count (fixnumize 1) count)))
+ (emit-label done))))
+
+
+;;; More args are stored consequtively on the stack, starting immediately at
+;;; the context pointer. The context pointer is not typed, so the lowtag is 0.
+;;;
+(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
+
+
+;;; Turn more arg (context, count) into a list.
+;;;
+(define-vop (listify-rest-args)
+ (:args (context-arg :target context :scs (descriptor-reg))
+ (count-arg :target count :scs (any-reg)))
+ (:arg-types * tagged-num)
+ (:temporary (:scs (any-reg) :from (:argument 0)) context)
+ (:temporary (:scs (any-reg) :from (:argument 1)) count)
+ (:temporary (:scs (descriptor-reg) :from :eval) temp dst)
+ (:results (result :scs (descriptor-reg)))
+ (:translate %listify-rest-args)
+ (:policy :safe)
+ (:generator 20
+ (let ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label)))
+ (move context-arg context)
+ (move count-arg count)
+ ;; Check to see if there are any arguments.
+ (move null-tn result)
+ (inst beq count done)
+
+ ;; We need to do this atomically.
+ (pseudo-atomic ()
+ ;; Allocate a cons (2 words) for each item.
+ (inst bis alloc-tn list-pointer-type result)
+ (move result dst)
+ (inst sll count 1 temp)
+ (inst addq alloc-tn temp alloc-tn)
+ (inst br zero-tn enter)
+
+ ;; Store the current cons in the cdr of the previous cons.
+ (emit-label loop)
+ (inst addq dst (* 2 word-bytes) dst)
+ (storew dst dst -1 list-pointer-type)
+
+ (emit-label enter)
+ ;; Grab one value.
+ (loadw temp context)
+ (inst addq context word-bytes context)
+
+ ;; Store the value in the car (in delay slot)
+ (storew temp dst 0 list-pointer-type)
+
+ ;; Dec count, and if != zero, go back for more.
+ (inst subq count (fixnumize 1) count)
+ (inst bne count loop)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-type))
+ (emit-label done))))
+
+;;; Return the location and size of the more arg glob created by Copy-More-Arg.
+;;; Supplied is the total number of arguments supplied (originally passed in
+;;; NARGS.) Fixed is the number of non-rest arguments.
+;;;
+;;; We must duplicate some of the work done by Copy-More-Arg, since at that
+;;; time the environment is in a pretty brain-damaged state, preventing this
+;;; info from being returned as values. What we do is compute
+;;; supplied - fixed, and return a pointer that many words below the current
+;;; stack top.
+;;;
+(define-vop (more-arg-context)
+ (:policy :fast-safe)
+ (:translate sb!c::%more-arg-context)
+ (:args (supplied :scs (any-reg)))
+ (:arg-types tagged-num (:constant fixnum))
+ (:info fixed)
+ (:results (context :scs (descriptor-reg))
+ (count :scs (any-reg)))
+ (:result-types t tagged-num)
+ (:note "more-arg-context")
+ (:generator 5
+ (inst subq supplied (fixnumize fixed) count)
+ (inst subq csp-tn count context)))
+
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+;;;
+(define-vop (verify-argument-count)
+ (:policy :fast-safe)
+ (:translate sb!c::%verify-argument-count)
+ (:args (nargs :scs (any-reg)))
+ (:arg-types positive-fixnum (:constant t))
+ (:temporary (:scs (any-reg) :type fixnum) temp)
+ (:info count)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (let ((err-lab
+ (generate-error-code vop invalid-argument-count-error nargs)))
+ (cond ((zerop count)
+ (inst bne nargs err-lab))
+ (t
+ (inst subq nargs (fixnumize count) temp)
+ (inst bne temp err-lab))))))
+
+;;; Various other error signalers.
+;;;
+(macrolet ((frob (name error translate &rest args)
+ `(define-vop (,name)
+ ,@(when translate
+ `((:policy :fast-safe)
+ (:translate ,translate)))
+ (:args ,@(mapcar #'(lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
+ args))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1000
+ (error-call vop ,error ,@args)))))
+ (frob argument-count-error invalid-argument-count-error
+ sb!c::%argument-count-error nargs)
+ (frob type-check-error object-not-type-error sb!c::%type-check-error
+ object type)
+ (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
+ object layout)
+ (frob odd-key-arguments-error odd-key-arguments-error
+ sb!c::%odd-key-arguments-error)
+ (frob unknown-key-argument-error unknown-key-argument-error
+ sb!c::%unknown-key-argument-error key)
+ (frob nil-function-returned-error nil-function-returned-error nil fun))
--- /dev/null
+;;; -*- Package: ALPHA; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of various primitive memory access
+;;; VOPs for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren
+;;;
+
+(in-package "SB!VM")
+
+
+\f
+;;;; Data object ref/set stuff.
+
+(define-vop (slot)
+ (:args (object :scs (descriptor-reg)))
+ (:info name offset lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:generator 1
+ (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg null zero)))
+ (:info name offset lowtag #+gengc remember)
+ (:ignore name)
+ (:results)
+ (:generator 1
+ #+gengc
+ (if remember
+ (storew-and-remember-slot value object offset lowtag)
+ (storew value object offset lowtag))
+ #-gengc
+ (storew value object offset lowtag)))
+
+\f
+;;;; Symbol hacking VOPs:
+
+;;; The compiler likes to be able to directly SET symbols.
+;;;
+(define-vop (set cell-set)
+ (:variant symbol-value-slot other-pointer-type))
+
+;;; Do a cell ref with an error check for being unbound.
+;;;
+(define-vop (checked-cell-ref)
+ (:args (object :scs (descriptor-reg) :target obj-temp))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
+
+;;; With Symbol-Value, we check that the value isn't the trap object. So
+;;; Symbol-Value of NIL is NIL.
+;;;
+(define-vop (symbol-value checked-cell-ref)
+ (:translate symbol-value)
+ (:generator 9
+ (move object obj-temp)
+ (loadw value obj-temp symbol-value-slot other-pointer-type)
+ (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
+ (inst xor value unbound-marker-type temp)
+ (inst beq temp err-lab))))
+
+;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
+(define-vop (boundp-frob)
+ (:args (object :scs (descriptor-reg)))
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:temporary (:scs (descriptor-reg)) value)
+ (:temporary (:scs (non-descriptor-reg)) temp))
+
+(define-vop (boundp boundp-frob)
+ (:translate boundp)
+ (:generator 9
+ (loadw value object symbol-value-slot other-pointer-type)
+ (inst xor value unbound-marker-type temp)
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target))))
+
+(define-vop (fast-symbol-value cell-ref)
+ (:variant symbol-value-slot other-pointer-type)
+ (:policy :fast)
+ (:translate symbol-value))
+
+
+\f
+;;;; Fdefinition (fdefn) objects.
+
+(define-vop (fdefn-function cell-ref)
+ (:variant fdefn-function-slot other-pointer-type))
+
+(define-vop (safe-fdefn-function)
+ (:args (object :scs (descriptor-reg) :target obj-temp))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 10
+ (move object obj-temp)
+ (loadw value obj-temp fdefn-function-slot other-pointer-type)
+ (let ((err-lab (generate-error-code vop undefined-symbol-error obj-temp)))
+ (inst cmpeq value null-tn temp)
+ (inst bne temp err-lab))))
+
+(define-vop (set-fdefn-function)
+ (:policy :fast-safe)
+ (:translate (setf fdefn-function))
+ (:args (function :scs (descriptor-reg) :target result)
+ (fdefn :scs (descriptor-reg)))
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:scs (non-descriptor-reg)) type)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 38
+ (let ((normal-fn (gen-label)))
+ (load-type type function (- function-pointer-type))
+ (inst xor type function-header-type type)
+ (inst addq function
+ (- (ash function-code-offset word-shift) function-pointer-type)
+ lip)
+ (inst beq type normal-fn)
+ (inst li (make-fixup "closure_tramp" :foreign) lip)
+ (emit-label normal-fn)
+ (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
+ (storew function fdefn fdefn-function-slot other-pointer-type)
+ (move function result))))
+
+
+(define-vop (fdefn-makunbound)
+ (:policy :fast-safe)
+ (:translate fdefn-makunbound)
+ (:args (fdefn :scs (descriptor-reg) :target result))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 38
+ (storew null-tn fdefn fdefn-function-slot other-pointer-type)
+ (inst li (make-fixup "undefined_tramp" :foreign) temp)
+ (move fdefn result)
+ (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)))
+
+
+\f
+;;;; Binding and Unbinding.
+
+;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+ (:args (val :scs (any-reg descriptor-reg))
+ (symbol :scs (descriptor-reg)))
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:generator 5
+ (loadw temp symbol symbol-value-slot other-pointer-type)
+ (inst addq bsp-tn (* 2 word-bytes) bsp-tn)
+ (storew temp bsp-tn (- binding-value-slot binding-size))
+ (storew symbol bsp-tn (- binding-symbol-slot binding-size))
+ (#+gengc storew-and-remember-slot #-gengc storew
+ val symbol symbol-value-slot other-pointer-type)))
+
+
+(define-vop (unbind)
+ (:temporary (:scs (descriptor-reg)) symbol value)
+ (:generator 0
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (#+gengc storew-and-remember-slot #-gengc storew
+ value symbol symbol-value-slot other-pointer-type)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+ (inst subq bsp-tn (* 2 word-bytes) bsp-tn)))
+
+
+(define-vop (unbind-to-here)
+ (:args (arg :scs (descriptor-reg any-reg) :target where))
+ (:temporary (:scs (any-reg) :from (:argument 0)) where)
+ (:temporary (:scs (descriptor-reg)) symbol value)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 0
+ (let ((loop (gen-label))
+ (skip (gen-label))
+ (done (gen-label)))
+ (move arg where)
+ (inst cmpeq where bsp-tn temp)
+ (inst bne temp done)
+
+ (emit-label loop)
+ (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
+ (loadw value bsp-tn (- binding-value-slot binding-size))
+ (inst beq symbol skip)
+ (#+gengc storew-and-remember-slot #-gengc storew
+ value symbol symbol-value-slot other-pointer-type)
+ (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+
+ (emit-label skip)
+ (inst subq bsp-tn (* 2 word-bytes) bsp-tn)
+ (inst cmpeq where bsp-tn temp)
+ (inst beq temp loop)
+
+ (emit-label done))))
+
+
+\f
+;;;; Closure indexing.
+
+(define-full-reffer closure-index-ref *
+ closure-info-offset function-pointer-type
+ (descriptor-reg any-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+ funcallable-instance-info-offset function-pointer-type
+ (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+ funcallable-instance-info-offset function-pointer-type
+ (descriptor-reg any-reg) * %funcallable-instance-info)
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+ (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+(define-vop (closure-ref slot-ref)
+ (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+ (:variant closure-info-offset function-pointer-type))
+
+\f
+;;;; Value Cell hackery.
+
+(define-vop (value-cell-ref cell-ref)
+ (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+ (:variant value-cell-value-slot other-pointer-type))
+
+
+\f
+;;;; Instance hackery:
+
+(define-vop (instance-length)
+ (:policy :fast-safe)
+ (:translate %instance-length)
+ (:args (struct :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (loadw res struct 0 instance-pointer-type)
+ (inst srl res type-bits res)))
+
+(define-vop (instance-ref slot-ref)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+ (:policy :fast-safe)
+ (:translate %instance-set)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+ instance-pointer-type (descriptor-reg any-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+ instance-pointer-type (descriptor-reg any-reg null zero) * %instance-set)
+
+
+\f
+;;;; Code object frobbing.
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+ (descriptor-reg any-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+ (descriptor-reg any-reg null zero) * code-header-set)
+
+
+\f
+;;;; Mutator accessing.
+
+#+gengc (progn
+
+(define-vop (mutator-ub32-ref)
+ (:policy :fast-safe)
+ (:args)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:variant-vars slot)
+ (:generator 2
+ (loadw res mutator-tn slot)))
+
+(define-vop (mutator-descriptor-ref mutator-ub32-ref)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:result-types *))
+
+(define-vop (mutator-sap-ref mutator-ub32-ref)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer))
+
+
+(define-vop (mutator-ub32-set)
+ (:policy :fast-safe)
+ (:args (arg :scs (unsigned-reg) :target res))
+ (:arg-types unsigned-num)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:variant-vars slot)
+ (:generator 2
+ (storew arg mutator-tn slot)
+ (move res arg)))
+
+(define-vop (mutator-descriptor-set mutator-ub32-set)
+ (:args (arg :scs (any-reg descriptor-reg null zero) :target res))
+ (:arg-types *)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:result-types *))
+
+(define-vop (mutator-sap-set mutator-ub32-set)
+ (:args (arg :scs (sap-reg) :target res))
+ (:arg-types system-area-pointer)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer))
+
+
+(macrolet ((define-mutator-accessors (slot type writable)
+ (let ((ref (symbolicate "MUTATOR-" slot "-REF"))
+ (set (and writable (symbolicate "MUTATOR-" slot "-SET")))
+ (offset (symbolicate "MUTATOR-" slot "-SLOT"))
+ (fn
+ (let ((*package* (find-package :kernel)))
+ (symbolicate "MUTATOR-" slot))))
+ (multiple-value-bind
+ (lisp-type ref-vop set-vop)
+ (ecase type
+ (:des
+ (values t 'mutator-descriptor-ref 'mutator-descriptor-set))
+ (:ub32
+ (values '(unsigned-byte 32) 'mutator-ub32-ref 'mutator-ub32-set))
+ (:sap
+ (values 'system-area-pointer 'mutator-sap-ref 'mutator-sap-set)))
+ `(progn
+ (export ',fn :kernel)
+ (defknown ,fn () ,lisp-type (flushable))
+ (define-vop (,ref ,ref-vop)
+ (:translate ,fn)
+ (:variant ,offset))
+ ,@(when writable
+ `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type (unsafe))
+ (define-vop (,set ,set-vop)
+ (:translate (setf ,fn))
+ (:variant ,offset)))))))))
+ (define-mutator-accessors thread :des t)
+ (define-mutator-accessors suspends-disabled-count :ub32 t)
+ (define-mutator-accessors suspend-pending :ub32 t)
+ (define-mutator-accessors control-stack-base :sap nil)
+ (define-mutator-accessors control-stack-end :sap nil)
+ (define-mutator-accessors current-unwind-protect :sap nil)
+ (define-mutator-accessors current-catch-block :sap nil)
+ (define-mutator-accessors binding-stack-base :sap nil)
+ (define-mutator-accessors binding-stack-end :sap nil)
+ (define-mutator-accessors number-stack-base :sap nil)
+ (define-mutator-accessors number-stack-end :sap nil)
+ (define-mutator-accessors eval-stack :des t)
+ (define-mutator-accessors eval-stack-top :ub32 t)
+ (define-mutator-accessors nursery-start :sap nil)
+ (define-mutator-accessors nursery-end :sap nil)
+ (define-mutator-accessors storebuf-start :sap nil)
+ (define-mutator-accessors storebuf-end :sap nil)
+ (define-mutator-accessors words-consed :ub32 nil))
+
+); #+gengc progn
--- /dev/null
+;;; -*- Package: C; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; $Header$
+;;;
+;;; This file contains the RT VM definition of character operations.
+;;;
+;;; Written by Rob MacLachlan
+;;; Converted for the Alpha by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+
+\f
+;;;; Moves and coercions:
+
+;;; Move a tagged char to an untagged representation.
+;;;
+(define-vop (move-to-base-char)
+ (:args (x :scs (any-reg descriptor-reg)))
+ (:results (y :scs (base-char-reg)))
+ (:generator 1
+ (inst srl x sb!vm:type-bits y)))
+;;;
+(define-move-vop move-to-base-char :move
+ (any-reg descriptor-reg) (base-char-reg))
+
+
+;;; Move an untagged char to a tagged representation.
+;;;
+(define-vop (move-from-base-char)
+ (:args (x :scs (base-char-reg)))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (inst sll x sb!vm:type-bits y)
+ (inst bis y sb!vm:base-char-type y)))
+;;;
+(define-move-vop move-from-base-char :move
+ (base-char-reg) (any-reg descriptor-reg))
+
+;;; Move untagged base-char values.
+;;;
+(define-vop (base-char-move)
+ (:args (x :target y
+ :scs (base-char-reg)
+ :load-if (not (location= x y))))
+ (:results (y :scs (base-char-reg)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move x y)))
+;;;
+(define-move-vop base-char-move :move
+ (base-char-reg) (base-char-reg))
+
+
+;;; Move untagged base-char arguments/return-values.
+;;;
+(define-vop (move-base-char-argument)
+ (:args (x :target y
+ :scs (base-char-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y base-char-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ (base-char-reg
+ (move x y))
+ (base-char-stack
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-base-char-argument :move-argument
+ (any-reg base-char-reg) (base-char-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+ (base-char-reg) (any-reg descriptor-reg))
+
+
+\f
+;;;; Other operations:
+
+(define-vop (char-code)
+ (:translate char-code)
+ (:policy :fast-safe)
+ (:args (ch :scs (base-char-reg) :target res))
+ (:arg-types base-char)
+ (:results (res :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (inst sll ch 2 res)))
+
+(define-vop (code-char)
+ (:translate code-char)
+ (:policy :fast-safe)
+ (:args (code :scs (any-reg) :target res))
+ (:arg-types positive-fixnum)
+ (:results (res :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 1
+ (inst srl code 2 res)))
+
+\f
+;;; Comparison of base-chars.
+;;;
+(define-vop (base-char-compare)
+ (:args (x :scs (base-char-reg))
+ (y :scs (base-char-reg)))
+ (:arg-types base-char base-char)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline comparison")
+ (:variant-vars cond)
+ (:generator 3
+ (ecase cond
+ (:eq (inst cmpeq x y temp))
+ (:lt (inst cmplt x y temp))
+ (:gt (inst cmplt y x temp)))
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target))))
+
+(define-vop (fast-char=/base-char base-char-compare)
+ (:translate char=)
+ (:variant :eq))
+
+(define-vop (fast-char</base-char base-char-compare)
+ (:translate char<)
+ (:variant :lt))
+
+(define-vop (fast-char>/base-char base-char-compare)
+ (:translate char>)
+ (:variant :gt))
--- /dev/null
+;;; -*- Package: ALPHA; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Compiler support for the new whizzy debugger.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+
+(define-vop (debug-cur-sp)
+ (:translate current-sp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move csp-tn res)))
+
+(define-vop (debug-cur-fp)
+ (:translate current-fp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move cfp-tn res)))
+
+(define-vop (read-control-stack)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (any-reg)))
+ (:arg-types system-area-pointer positive-fixnum)
+ (:temporary (:scs (sap-reg) :from :eval) sap)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (inst addq object offset sap)
+ (inst ldl result 0 sap)))
+
+(define-vop (read-control-stack-c)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 14)))
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 4
+ (inst ldl result (* offset word-bytes) object)))
+
+(define-vop (write-control-stack)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (any-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:arg-types system-area-pointer positive-fixnum *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:temporary (:scs (sap-reg) :from (:argument 1)) sap)
+ (:generator 2
+ (inst addq object offset sap)
+ (inst stl value 0 sap)
+ (move value result)))
+
+(define-vop (write-control-stack-c)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:info offset)
+ (:arg-types system-area-pointer (:constant (signed-byte 14)) *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 1
+ (inst stl value (* offset word-bytes) sap)
+ (move value result)))
+
+
+(define-vop (code-from-mumble)
+ (:policy :fast-safe)
+ (:args (thing :scs (descriptor-reg)))
+ (:results (code :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:variant-vars lowtag)
+ (:generator 5
+ (let ((bogus (gen-label))
+ (done (gen-label)))
+ (loadw temp thing 0 lowtag)
+ (inst srl temp sb!vm:type-bits temp)
+ (inst beq temp bogus)
+ (inst sll temp (1- (integer-length sb!vm:word-bytes)) temp)
+ (unless (= lowtag sb!vm:other-pointer-type)
+ (inst subq temp (- sb!vm:other-pointer-type lowtag) temp))
+ (inst subq thing temp code)
+ (emit-label done)
+ (assemble (*elsewhere*)
+ (emit-label bogus)
+ (move null-tn code)
+ (inst br zero-tn done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+ (:translate lra-code-header)
+ (:variant sb!vm:other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+ (:translate function-code-header)
+ (:variant sb!vm:function-pointer-type))
+
+(define-vop (make-lisp-obj)
+ (:policy :fast-safe)
+ (:translate make-lisp-obj)
+ (:args (value :scs (unsigned-reg) :target result))
+ (:arg-types unsigned-num)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 1
+ (move value result)))
+
+(define-vop (get-lisp-obj-address)
+ (:policy :fast-safe)
+ (:translate get-lisp-obj-address)
+ (:args (thing :scs (descriptor-reg) :target result))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move thing result)))
+
+(define-vop (function-word-offset)
+ (:policy :fast-safe)
+ (:translate function-word-offset)
+ (:args (fun :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (loadw res fun 0 function-pointer-type)
+ (inst srl res sb!vm:type-bits res)))
+
+
+
+
+(defknown make-number-stack-pointer ((unsigned-byte 32)) system-area-pointer
+ (movable foldable flushable))
+
+(define-vop (make-number-stack-pointer)
+ (:policy :fast-safe)
+ (:translate make-number-stack-pointer)
+ (:args (arg :scs (unsigned-reg) :to (:argument 1)))
+ (:arg-types unsigned-num)
+ (:results (res :scs (sap-reg) :from (:argument 0)))
+ (:result-types system-area-pointer)
+ (:generator 5
+ (inst mskll nsp-tn 0 res)
+ (inst bis res arg res)))
--- /dev/null
+;;; This file contains floating point support for the Alpha.
+
+(in-package "SB!VM")
+
+
+\f
+;;;; Move functions:
+
+(define-move-function (load-fp-zero 1) (vop x y)
+ ((fp-single-zero) (single-reg)
+ (fp-double-zero) (double-reg))
+ (inst fmove x y))
+
+(define-move-function (load-single 1) (vop x y)
+ ((single-stack) (single-reg))
+ (inst lds y (* (tn-offset x) word-bytes) (current-nfp-tn vop)))
+
+(define-move-function (store-single 1) (vop x y)
+ ((single-reg) (single-stack))
+ (inst sts x (* (tn-offset y) word-bytes) (current-nfp-tn vop)))
+
+
+(define-move-function (load-double 2) (vop x y)
+ ((double-stack) (double-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) word-bytes)))
+ (inst ldt y offset nfp)))
+
+(define-move-function (store-double 2) (vop x y)
+ ((double-reg) (double-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) word-bytes)))
+ (inst stt x offset nfp)))
+
+
+\f
+;;;; Move VOPs:
+
+(macrolet ((frob (vop sc)
+ `(progn
+ (define-vop (,vop)
+ (:args (x :scs (,sc)
+ :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (,sc)
+ :load-if (not (location= x y))))
+ (:note "float move")
+ (:generator 0
+ (unless (location= y x)
+ (inst fmove x y))))
+ (define-move-vop ,vop :move (,sc) (,sc)))))
+ (frob single-move single-reg)
+ (frob double-move double-reg))
+
+
+(define-vop (move-from-float)
+ (:args (x :to :save))
+ (:results (y))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:variant-vars double-p size type data)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr type size)
+ (if double-p
+ (inst stt x (- (* data word-bytes) other-pointer-type) y)
+ (inst sts x (- (* data word-bytes) other-pointer-type) y)))))
+
+(macrolet ((frob (name sc &rest args)
+ `(progn
+ (define-vop (,name move-from-float)
+ (:args (x :scs (,sc) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:variant ,@args))
+ (define-move-vop ,name :move (,sc) (descriptor-reg)))))
+ (frob move-from-single single-reg
+ nil single-float-size single-float-type single-float-value-slot)
+ (frob move-from-double double-reg
+ t double-float-size double-float-type double-float-value-slot))
+
+(macrolet ((frob (name sc double-p value)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ ,@(if double-p
+ `((inst ldt y (- (* ,value word-bytes)
+ other-pointer-type)
+ x))
+ `((inst lds y (- (* ,value word-bytes)
+ other-pointer-type)
+ x)))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-single single-reg nil single-float-value-slot)
+ (frob move-to-double double-reg t double-float-value-slot))
+
+
+(macrolet ((frob (name sc stack-sc double-p)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (nfp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(if double-p 2 1)
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (inst fmove x y)))
+ (,stack-sc
+ (let ((offset (* (tn-offset y) word-bytes)))
+ ,@(if double-p
+ '((inst stt x offset nfp))
+ '((inst sts x offset nfp))))))))
+ (define-move-vop ,name :move-argument
+ (,sc descriptor-reg) (,sc)))))
+ (frob move-single-float-argument single-reg single-stack nil)
+ (frob move-double-float-argument double-reg double-stack t))
+
+\f
+;;;; Complex float move functions
+
+(defun complex-single-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
+ :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg )
+ :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
+ :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg )
+ :offset (1+ (tn-offset x))))
+
+
+(define-move-function (load-complex-single 2) (vop x y)
+ ((complex-single-stack) (complex-single-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) sb!vm:word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn y)))
+ (inst lds real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst lds imag-tn (+ offset sb!vm:word-bytes) nfp))))
+
+(define-move-function (store-complex-single 2) (vop x y)
+ ((complex-single-reg) (complex-single-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) sb!vm:word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst sts real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst sts imag-tn (+ offset sb!vm:word-bytes) nfp))))
+
+
+(define-move-function (load-complex-double 4) (vop x y)
+ ((complex-double-stack) (complex-double-reg))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset x) sb!vm:word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (inst ldt real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (inst ldt imag-tn (+ offset (* 2 sb!vm:word-bytes)) nfp))))
+
+(define-move-function (store-complex-double 4) (vop x y)
+ ((complex-double-reg) (complex-double-stack))
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset y) sb!vm:word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stt real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stt imag-tn (+ offset (* 2 sb!vm:word-bytes)) nfp))))
+
+;;;
+;;; Complex float register to register moves.
+;;;
+(define-vop (complex-single-move)
+ (:args (x :scs (complex-single-reg) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (complex-single-reg) :load-if (not (location= x y))))
+ (:note "complex single float move")
+ (:generator 0
+ (unless (location= x y)
+ ;; Note the complex-float-regs are aligned to every second
+ ;; float register so there is not need to worry about overlap.
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmove x-real y-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove x-imag y-imag)))))
+;;;
+(define-move-vop complex-single-move :move
+ (complex-single-reg) (complex-single-reg))
+
+(define-vop (complex-double-move)
+ (:args (x :scs (complex-double-reg)
+ :target y :load-if (not (location= x y))))
+ (:results (y :scs (complex-double-reg) :load-if (not (location= x y))))
+ (:note "complex double float move")
+ (:generator 0
+ (unless (location= x y)
+ ;; Note the complex-float-regs are aligned to every second
+ ;; float register so there is not need to worry about overlap.
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmove x-real y-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove x-imag y-imag)))))
+;;;
+(define-move-vop complex-double-move :move
+ (complex-double-reg) (complex-double-reg))
+
+;;;
+;;; Move from a complex float to a descriptor register allocating a
+;;; new complex float object in the process.
+;;;
+(define-vop (move-from-complex-single)
+ (:args (x :scs (complex-single-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:note "complex single float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr sb!vm:complex-single-float-type
+ sb!vm:complex-single-float-size)
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst sts real-tn (- (* sb!vm:complex-single-float-real-slot
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ y))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst sts imag-tn (- (* sb!vm:complex-single-float-imag-slot
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ y)))))
+;;;
+(define-move-vop move-from-complex-single :move
+ (complex-single-reg) (descriptor-reg))
+
+(define-vop (move-from-complex-double)
+ (:args (x :scs (complex-double-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:note "complex double float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y ndescr sb!vm:complex-double-float-type
+ sb!vm:complex-double-float-size)
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stt real-tn (- (* sb!vm:complex-double-float-real-slot
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ y))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stt imag-tn (- (* sb!vm:complex-double-float-imag-slot
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ y)))))
+;;;
+(define-move-vop move-from-complex-double :move
+ (complex-double-reg) (descriptor-reg))
+
+;;;
+;;; Move from a descriptor to a complex float register
+;;;
+(define-vop (move-to-complex-single)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (complex-single-reg)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-single-reg-real-tn y)))
+ (inst lds real-tn (- (* complex-single-float-real-slot sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ x))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (inst lds imag-tn (- (* complex-single-float-imag-slot sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ x))))
+(define-move-vop move-to-complex-single :move
+ (descriptor-reg) (complex-single-reg))
+
+(define-vop (move-to-complex-double)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (complex-double-reg)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (inst ldt real-tn (- (* complex-double-float-real-slot sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ x))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (inst ldt imag-tn (- (* complex-double-float-imag-slot sb!vm:word-bytes)
+ sb!vm:other-pointer-type)
+ x))))
+(define-move-vop move-to-complex-double :move
+ (descriptor-reg) (complex-double-reg))
+
+;;;
+;;; Complex float move-argument vop
+;;;
+(define-vop (move-complex-single-float-argument)
+ (:args (x :scs (complex-single-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-single-reg))))
+ (:results (y))
+ (:note "complex single float argument move")
+ (:generator 1
+ (sc-case y
+ (complex-single-reg
+ (unless (location= x y)
+ (let ((x-real (complex-single-reg-real-tn x))
+ (y-real (complex-single-reg-real-tn y)))
+ (inst fmove x-real y-real))
+ (let ((x-imag (complex-single-reg-imag-tn x))
+ (y-imag (complex-single-reg-imag-tn y)))
+ (inst fmove x-imag y-imag))))
+ (complex-single-stack
+ (let ((offset (* (tn-offset y) sb!vm:word-bytes)))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (inst sts real-tn offset nfp))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst sts imag-tn (+ offset word-bytes) nfp)))))))
+(define-move-vop move-complex-single-float-argument :move-argument
+ (complex-single-reg descriptor-reg) (complex-single-reg))
+
+(define-vop (move-complex-double-float-argument)
+ (:args (x :scs (complex-double-reg) :target y)
+ (nfp :scs (any-reg) :load-if (not (sc-is y complex-double-reg))))
+ (:results (y))
+ (:note "complex double float argument move")
+ (:generator 2
+ (sc-case y
+ (complex-double-reg
+ (unless (location= x y)
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (inst fmove x-real y-real))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fmove x-imag y-imag))))
+ (complex-double-stack
+ (let ((offset (* (tn-offset y) sb!vm:word-bytes)))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (inst stt real-tn offset nfp))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst stt imag-tn (+ offset (* 2 word-bytes)) nfp)))))))
+(define-move-vop move-complex-double-float-argument :move-argument
+ (complex-double-reg descriptor-reg) (complex-double-reg))
+
+
+(define-move-vop move-argument :move-argument
+ (single-reg double-reg complex-single-reg complex-double-reg)
+ (descriptor-reg))
+
+\f
+;;;; Arithmetic VOPs:
+
+(define-vop (float-op)
+ (:args (x) (y))
+ (:results (r))
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+;;; Need to insure that ops that can cause traps do not clobber an
+;;; argument register with invalid results. This so the software
+;;; trap handler can re-execute the instruction and produce correct
+;;; IEEE result. The :from :load hopefully does that.
+(macrolet ((frob (name sc ptype)
+ `(define-vop (,name float-op)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:results (r :scs (,sc) :from :load))
+ (:arg-types ,ptype ,ptype)
+ (:result-types ,ptype))))
+ (frob single-float-op single-reg single-float)
+ (frob double-float-op double-reg double-float))
+
+;; This is resumption-safe with underflow traps enabled,
+;; with software handling and (notyet) dynamic rounding mode.
+(macrolet ((frob (op sinst sname scost dinst dname dcost)
+ `(progn
+ (define-vop (,sname single-float-op)
+ (:translate ,op)
+ (:variant-cost ,scost)
+ (:generator ,scost
+ (inst ,sinst x y r)
+ (note-this-location vop :internal-error)
+ (inst trapb)))
+ (define-vop (,dname double-float-op)
+ (:translate ,op)
+ (:variant-cost ,dcost)
+ (:generator ,dcost
+ (inst ,dinst x y r)
+ (note-this-location vop :internal-error)
+ (inst trapb))))))
+ ;; Not sure these cost number are right. +*- about same / is 4x
+ (frob + adds_su +/single-float 1 addt_su +/double-float 1)
+ (frob - subs_su -/single-float 1 subt_su -/double-float 1)
+ (frob * muls_su */single-float 1 mult_su */double-float 1)
+ (frob / divs_su //single-float 4 divt_su //double-float 4))
+
+(macrolet ((frob (name inst translate sc type)
+ `(define-vop (,name)
+ (:args (x :scs (,sc) :target y))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (inst ,inst x y)))))
+ (frob abs/single-float fabs abs single-reg single-float)
+ (frob abs/double-float fabs abs double-reg double-float)
+ (frob %negate/single-float fneg %negate single-reg single-float)
+ (frob %negate/double-float fneg %negate double-reg double-float))
+
+\f
+;;;; Comparison:
+
+(define-vop (float-compare)
+ (:args (x) (y))
+ (:conditional)
+ (:info target not-p)
+ (:variant-vars eq complement)
+ (:temporary (:scs (single-reg)) temp)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (if eq
+ (inst cmpteq x y temp)
+ (if complement
+ (inst cmptle x y temp)
+ (inst cmptlt x y temp)))
+ (inst trapb)
+ (if (if complement (not not-p) not-p)
+ (inst fbeq temp target)
+ (inst fbne temp target))))
+
+(macrolet ((frob (name sc ptype)
+ `(define-vop (,name float-compare)
+ (:args (x :scs (,sc))
+ (y :scs (,sc)))
+ (:arg-types ,ptype ,ptype))))
+ (frob single-float-compare single-reg single-float)
+ (frob double-float-compare double-reg double-float))
+
+(macrolet ((frob (translate complement sname dname eq)
+ `(progn
+ (define-vop (,sname single-float-compare)
+ (:translate ,translate)
+ (:variant ,eq ,complement))
+ (define-vop (,dname double-float-compare)
+ (:translate ,translate)
+ (:variant ,eq ,complement)))))
+ (frob < nil </single-float </double-float nil)
+ (frob > t >/single-float >/double-float nil)
+ (frob = nil =/single-float =/double-float t))
+
+\f
+;;;; Conversion:
+
+(macrolet
+ ((frob (name translate inst ld-inst to-sc to-type &optional single)
+ (declare (ignorable single))
+ `(define-vop (,name)
+ (:args (x :scs (signed-reg) :target temp
+ :load-if (not (sc-is x signed-stack))))
+ (:temporary (:scs (single-stack)) temp)
+ (:results (y :scs (,to-sc)))
+ (:arg-types signed-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (let ((stack-tn
+ (sc-case x
+ (signed-reg
+ (inst stl x
+ (* (tn-offset temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ temp)
+ (signed-stack
+ x))))
+ (inst ,ld-inst y
+ (* (tn-offset stack-tn) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (note-this-location vop :internal-error)
+ ,@(when single
+ `((inst cvtlq y y)))
+ (inst ,inst y y))))))
+ (frob %single-float/signed %single-float cvtqs lds single-reg single-float t)
+ (frob %double-float/signed %double-float cvtqt lds double-reg double-float t))
+
+(macrolet ((frob (name translate inst from-sc from-type to-sc to-type)
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc)))
+ (:results (y :scs (,to-sc)))
+ (:arg-types ,from-type)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (inst ,inst x y)))))
+ (frob %single-float/double-float %single-float cvtts
+ double-reg double-float single-reg single-float)
+ (frob %double-float/single-float %double-float fmove
+ single-reg single-float double-reg double-float))
+
+(macrolet
+ ((frob (trans from-sc from-type inst &optional single)
+ (declare (ignorable single))
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc) :target temp))
+ (:temporary (:from (:argument 0) :sc single-reg) temp)
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:results (y :scs (signed-reg)
+ :load-if (not (sc-is y signed-stack))))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (inst ,inst x temp)
+ (sc-case y
+ (signed-stack
+ (inst stt temp
+ (* (tn-offset y) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (signed-reg
+ (inst stt temp
+ (* (tn-offset stack-temp)
+ sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst ldq y
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))))))))
+ (frob %unary-truncate single-reg single-float cvttq/c t)
+ (frob %unary-truncate double-reg double-float cvttq/c)
+ (frob %unary-round single-reg single-float cvttq t)
+ (frob %unary-round double-reg double-float cvttq))
+
+(define-vop (make-single-float)
+ (:args (bits :scs (signed-reg) :target res
+ :load-if (not (sc-is bits signed-stack))))
+ (:results (res :scs (single-reg)
+ :load-if (not (sc-is res single-stack))))
+ (:temporary (:scs (signed-reg) :from (:argument 0) :to (:result 0)) temp)
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:arg-types signed-num)
+ (:result-types single-float)
+ (:translate make-single-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 4
+ (sc-case bits
+ (signed-reg
+ (sc-case res
+ (single-reg
+ (inst stl bits
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst lds res
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (single-stack
+ (inst stl bits
+ (* (tn-offset res) sb!vm:word-bytes)
+ (current-nfp-tn vop)))))
+ (signed-stack
+ (sc-case res
+ (single-reg
+ (inst lds res
+ (* (tn-offset bits) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (single-stack
+ (unless (location= bits res)
+ (inst ldl temp
+ (* (tn-offset bits) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst stl temp
+ (* (tn-offset res) sb!vm:word-bytes)
+ (current-nfp-tn vop)))))))))
+
+(define-vop (make-double-float)
+ (:args (hi-bits :scs (signed-reg))
+ (lo-bits :scs (unsigned-reg)))
+ (:results (res :scs (double-reg)
+ :load-if (not (sc-is res double-stack))))
+ (:temporary (:scs (double-stack)) temp)
+ (:arg-types signed-num unsigned-num)
+ (:result-types double-float)
+ (:translate make-double-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 2
+ (let ((stack-tn (sc-case res
+ (double-stack res)
+ (double-reg temp))))
+ (inst stl hi-bits
+ (* (1+ (tn-offset stack-tn)) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst stl lo-bits
+ (* (tn-offset stack-tn) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (when (sc-is res double-reg)
+ (inst ldt res
+ (* (tn-offset temp) sb!vm:word-bytes)
+ (current-nfp-tn vop)))))
+
+(define-vop (single-float-bits)
+ (:args (float :scs (single-reg descriptor-reg)
+ :load-if (not (sc-is float single-stack))))
+ (:results (bits :scs (signed-reg)
+ :load-if (or (sc-is float descriptor-reg single-stack)
+ (not (sc-is bits signed-stack)))))
+ (:temporary (:scs (signed-stack)) stack-temp)
+ (:arg-types single-float)
+ (:result-types signed-num)
+ (:translate single-float-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 4
+ (sc-case bits
+ (signed-reg
+ (sc-case float
+ (single-reg
+ (inst sts float
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst ldl bits
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (single-stack
+ (inst ldl bits
+ (* (tn-offset float) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (descriptor-reg
+ (loadw bits float sb!vm:single-float-value-slot sb!vm:other-pointer-type))))
+ (signed-stack
+ (sc-case float
+ (single-reg
+ (inst sts float
+ (* (tn-offset bits) sb!vm:word-bytes)
+ (current-nfp-tn vop))))))))
+
+(define-vop (double-float-high-bits)
+ (:args (float :scs (double-reg descriptor-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (hi-bits :scs (signed-reg)))
+ (:temporary (:scs (double-stack)) stack-temp)
+ (:arg-types double-float)
+ (:result-types signed-num)
+ (:translate double-float-high-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (double-reg
+ (inst stt float
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst ldl hi-bits
+ (* (1+ (tn-offset stack-temp)) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (double-stack
+ (inst ldl hi-bits
+ (* (1+ (tn-offset float)) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (descriptor-reg
+ (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
+ sb!vm:other-pointer-type)))))
+
+(define-vop (double-float-low-bits)
+ (:args (float :scs (double-reg descriptor-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (lo-bits :scs (unsigned-reg)))
+ (:temporary (:scs (double-stack)) stack-temp)
+ (:arg-types double-float)
+ (:result-types unsigned-num)
+ (:translate double-float-low-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (double-reg
+ (inst stt float
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop))
+ (inst ldl lo-bits
+ (* (tn-offset stack-temp) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (double-stack
+ (inst ldl lo-bits
+ (* (tn-offset float) sb!vm:word-bytes)
+ (current-nfp-tn vop)))
+ (descriptor-reg
+ (loadw lo-bits float sb!vm:double-float-value-slot
+ sb!vm:other-pointer-type)))
+ (inst mskll lo-bits 4 lo-bits)))
+
+\f
+;;;; Float mode hackery:
+
+(sb!xc:deftype float-modes () '(unsigned-byte 32)) ;actually 24 -dan
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+ float-modes)
+
+;;; Modes bits are (byte 12 52) of fpcr. Grab and return in low bits.
+(define-vop (floating-point-modes)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:translate floating-point-modes)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:temporary (:sc double-stack) temp)
+ (:temporary (:sc double-reg) temp1)
+ (:generator 5
+ (let ((nfp (current-nfp-tn vop)))
+ (inst excb)
+ (inst mf_fpcr temp1 temp1 temp1)
+ (inst excb)
+ (inst stt temp1 (* word-bytes (tn-offset temp)) nfp)
+ (inst ldl res (* (1+ (tn-offset temp)) sb!vm:word-bytes) nfp)
+ (inst srl res 49 res))))
+
+(define-vop (set-floating-point-modes)
+ (:args (new :scs (unsigned-reg) :target res))
+ (:results (res :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:result-types unsigned-num)
+ (:translate (setf floating-point-modes))
+ (:policy :fast-safe)
+ (:temporary (:sc double-stack) temp)
+ (:temporary (:sc double-reg) temp1)
+ (:vop-var vop)
+ (:generator 8
+ (let ((nfp (current-nfp-tn vop)))
+ (inst sll new 49 res)
+ (inst stl zero-tn (* (tn-offset temp) sb!vm:word-bytes) nfp)
+ (inst stl res (* (1+ (tn-offset temp)) sb!vm:word-bytes) nfp)
+ (inst ldt temp1 (* (tn-offset temp) sb!vm:word-bytes) nfp)
+ (inst excb)
+ (inst mt_fpcr temp1 temp1 temp1)
+ (inst excb)
+ (move res new))))
+
+\f
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+ (:translate complex)
+ (:args (real :scs (single-reg) :target r)
+ (imag :scs (single-reg) :to :save))
+ (:arg-types single-float single-float)
+ (:results (r :scs (complex-single-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-single-stack))))
+ (:result-types complex-single-float)
+ (:note "inline complex single-float creation")
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case r
+ (complex-single-reg
+ (let ((r-real (complex-single-reg-real-tn r)))
+ (unless (location= real r-real)
+ (inst fmove real r-real)))
+ (let ((r-imag (complex-single-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst fmove imag r-imag))))
+ (complex-single-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) sb!vm:word-bytes)))
+ (inst sts real offset nfp)
+ (inst sts imag (+ offset sb!vm:word-bytes) nfp))))))
+
+(define-vop (make-complex-double-float)
+ (:translate complex)
+ (:args (real :scs (double-reg) :target r)
+ (imag :scs (double-reg) :to :save))
+ (:arg-types double-float double-float)
+ (:results (r :scs (complex-double-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-double-stack))))
+ (:result-types complex-double-float)
+ (:note "inline complex double-float creation")
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case r
+ (complex-double-reg
+ (let ((r-real (complex-double-reg-real-tn r)))
+ (unless (location= real r-real)
+ (inst fmove real r-real)))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (inst fmove imag r-imag))))
+ (complex-double-stack
+ (let ((nfp (current-nfp-tn vop))
+ (offset (* (tn-offset r) sb!vm:word-bytes)))
+ (inst stt real offset nfp)
+ (inst stt imag (+ offset (* 2 sb!vm:word-bytes)) nfp))))))
+
+(define-vop (complex-single-float-value)
+ (:args (x :scs (complex-single-reg) :target r
+ :load-if (not (sc-is x complex-single-stack))))
+ (:arg-types complex-single-float)
+ (:results (r :scs (single-reg)))
+ (:result-types single-float)
+ (:variant-vars slot)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ (sc-case x
+ (complex-single-reg
+ (let ((value-tn (ecase slot
+ (:real (complex-single-reg-real-tn x))
+ (:imag (complex-single-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmove value-tn r))))
+ (complex-single-stack
+ (inst lds r (* (+ (ecase slot (:real 0) (:imag 1)) (tn-offset x))
+ sb!vm:word-bytes)
+ (current-nfp-tn vop))))))
+
+(define-vop (realpart/complex-single-float complex-single-float-value)
+ (:translate realpart)
+ (:note "complex single float realpart")
+ (:variant :real))
+
+(define-vop (imagpart/complex-single-float complex-single-float-value)
+ (:translate imagpart)
+ (:note "complex single float imagpart")
+ (:variant :imag))
+
+(define-vop (complex-double-float-value)
+ (:args (x :scs (complex-double-reg) :target r
+ :load-if (not (sc-is x complex-double-stack))))
+ (:arg-types complex-double-float)
+ (:results (r :scs (double-reg)))
+ (:result-types double-float)
+ (:variant-vars slot)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ (sc-case x
+ (complex-double-reg
+ (let ((value-tn (ecase slot
+ (:real (complex-double-reg-real-tn x))
+ (:imag (complex-double-reg-imag-tn x)))))
+ (unless (location= value-tn r)
+ (inst fmove value-tn r))))
+ (complex-double-stack
+ (inst ldt r (* (+ (ecase slot (:real 0) (:imag 2)) (tn-offset x))
+ sb!vm:word-bytes)
+ (current-nfp-tn vop))))))
+
+(define-vop (realpart/complex-double-float complex-double-float-value)
+ (:translate realpart)
+ (:note "complex double float realpart")
+ (:variant :real))
+
+(define-vop (imagpart/complex-double-float complex-double-float-value)
+ (:translate imagpart)
+ (:note "complex double float imagpart")
+ (:variant :imag))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the instruction set definition for the Alpha.
+;;;
+;;; Written by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+;;;(def-assembler-params
+;;; :scheduler-p nil)
+
+;;; ../x86/insts contains the invocation
+;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 1)
+;;; which apparently was another use of def-assembler-params
+
+\f
+;;;; Utility functions.
+
+(defun reg-tn-encoding (tn)
+ (declare (type tn tn)
+ (values (unsigned-byte 5)))
+ (sc-case tn
+ (zero zero-offset)
+ (null null-offset)
+ (t
+ (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (tn-offset tn))))
+
+(defun fp-reg-tn-encoding (tn)
+ (declare (type tn tn))
+ (sc-case tn
+ (fp-single-zero (tn-offset fp-single-zero-tn))
+ (fp-double-zero (tn-offset fp-double-zero-tn))
+ (t
+ (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
+ (error "~S isn't a floating-point register." tn))
+ (tn-offset tn))))
+
+\f
+;;;; Initial disassembler setup.
+
+;; XXX find out what this was supposed to do
+;; (sb!disassem:set-disassem-params :instruction-alignment 32)
+
+(defvar *disassem-use-lisp-reg-names* t)
+
+(defparameter reg-symbols
+ (map 'vector
+ #'(lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
+ *register-names*))
+
+(sb!disassem:define-argument-type reg
+ :printer #'(lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
+
+(defparameter float-reg-symbols
+ (coerce
+ (loop for n from 0 to 31 collect (make-symbol (format nil "~d" n)))
+ 'vector))
+
+(sb!disassem:define-argument-type fp-reg
+ :printer #'(lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
+
+(sb!disassem:define-argument-type relative-label
+ :sign-extend t
+ :use-label #'(lambda (value dstate)
+ (declare (type (signed-byte 21) value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (ash value 2) (sb!disassem:dstate-cur-addr dstate))))
+
+
+\f
+;;;; Define-instruction-formats for disassembler.
+(sb!disassem:define-instruction-format
+ (memory 32 :default-printer '(:name :tab ra "," disp "(" rb ")"))
+ (op :field (byte 6 26))
+ (ra :field (byte 5 21) :type 'reg)
+ (rb :field (byte 5 16) :type 'reg)
+ (disp :field (byte 16 0) :sign-extend t))
+
+(sb!disassem:define-instruction-format
+ (jump 32 :default-printer '(:name :tab ra ",(" rb ")," hint))
+ (op :field (byte 6 26))
+ (ra :field (byte 5 21) :type 'reg)
+ (rb :field (byte 5 16) :type 'reg)
+ (subop :field (byte 2 14))
+ (hint :field (byte 14 0)))
+
+(sb!disassem:define-instruction-format
+ (branch 32 :default-printer '(:name :tab ra "," disp))
+ (op :field (byte 6 26))
+ (ra :field (byte 5 21) :type 'reg)
+ (disp :field (byte 21 0) :type 'relative-label))
+
+(sb!disassem:define-instruction-format
+ (reg-operate 32 :default-printer '(:name :tab ra "," rb "," rc))
+ (op :field (byte 6 26))
+ (ra :field (byte 5 21) :type 'reg)
+ (rb :field (byte 5 16) :type 'reg)
+ (sbz :field (byte 3 13))
+ (f :field (byte 1 12) :value 0)
+ (fn :field (byte 7 5))
+ (rc :field (byte 5 0) :type 'reg))
+
+(sb!disassem:define-instruction-format
+ (lit-operate 32 :default-printer '(:name :tab ra "," lit "," rc))
+ (op :field (byte 6 26))
+ (ra :field (byte 5 21) :type 'reg)
+ (lit :field (byte 8 13))
+ (f :field (byte 1 12) :value 1)
+ (fn :field (byte 7 5))
+ (rc :field (byte 5 0) :type 'reg))
+
+(sb!disassem:define-instruction-format
+ (fp-operate 32 :default-printer '(:name :tab fa "," fb "," fc))
+ (op :field (byte 6 26))
+ (fa :field (byte 5 21) :type 'fp-reg)
+ (fb :field (byte 5 16) :type 'fp-reg)
+ (fn :field (byte 11 5))
+ (fc :field (byte 5 0) :type 'fp-reg))
+
+(sb!disassem:define-instruction-format
+ (call-pal 32 :default-printer '('call_pal :tab 'pal_ :name))
+ (op :field (byte 6 26) :value 0)
+ (palcode :field (byte 26 0)))
+
+\f
+;;;; Emitters.
+(define-bitfield-emitter emit-word 16
+ (byte 16 0))
+
+(define-bitfield-emitter emit-lword 32
+ (byte 32 0))
+
+(define-bitfield-emitter emit-qword 64
+ (byte 64 0))
+
+(define-bitfield-emitter emit-memory 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 16 0))
+
+(define-bitfield-emitter emit-branch 32
+ (byte 6 26) (byte 5 21) (byte 21 0))
+
+(define-bitfield-emitter emit-reg-operate 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13) (byte 1 12) (byte 7 5)
+ (byte 5 0))
+
+(define-bitfield-emitter emit-lit-operate 32
+ (byte 6 26) (byte 5 21) (byte 8 13) (byte 1 12) (byte 7 5) (byte 5 0))
+
+(define-bitfield-emitter emit-fp-operate 32
+ (byte 6 26) (byte 5 21) (byte 5 16) (byte 11 5) (byte 5 0))
+
+(define-bitfield-emitter emit-pal 32
+ (byte 6 26) (byte 26 0))
+
+\f
+;;;; Macros for instructions.
+(macrolet ((define-memory (name op &optional fixup float)
+ `(define-instruction ,name (segment ra disp rb ,@(if fixup
+ '(&optional type)))
+ (:declare (type tn ra rb)
+ ,@(if fixup ; ### unsigned-byte 16 bad idea?
+ '((type (or (unsigned-byte 16) (signed-byte 16) fixup)
+ disp))
+ '((type (or (unsigned-byte 16) (signed-byte 16)) disp))))
+ (:printer memory ((op ,op)))
+ (:emitter
+ ,@(when fixup
+ `((when (fixup-p disp)
+ (note-fixup segment (or type ,fixup) disp)
+ (setf disp 0))))
+ (emit-memory segment ,op ,@(if float
+ '((fp-reg-tn-encoding ra))
+ '((reg-tn-encoding ra)))
+ (reg-tn-encoding rb)
+ disp)))))
+ (define-memory lda #x08 :lda)
+ (define-memory ldah #x09 :ldah)
+ (define-memory ldl #x28)
+ (define-memory ldq #x29)
+ (define-memory ldl_l #x2a)
+ (define-memory ldq_q #x2b)
+ (define-memory ldq_u #x0b)
+ (define-memory stl #x2c)
+ (define-memory stq #x2d)
+ (define-memory stl_c #x2e)
+ (define-memory stq_c #x2f)
+ (define-memory stq_u #x0f)
+ (define-memory ldf #x20 nil t)
+ (define-memory ldg #x21 nil t)
+ (define-memory lds #x22 nil t)
+ (define-memory ldt #x23 nil t)
+ (define-memory stf #x24 nil t)
+ (define-memory stg #x25 nil t)
+ (define-memory sts #x26 nil t)
+ (define-memory stt #x27 nil t))
+
+(macrolet ((define-jump (name subop)
+ `(define-instruction ,name (segment ra rb &optional (hint 0))
+ (:declare (type tn ra rb)
+ (type (or (unsigned-byte 14) fixup) hint))
+ (:printer jump ((op #x1a) (subop ,subop)))
+ (:emitter
+ (when (fixup-p hint)
+ (note-fixup segment :jmp-hint hint)
+ (setf hint 0))
+ (emit-memory segment #x1a (reg-tn-encoding ra) (reg-tn-encoding rb)
+ (logior (ash ,subop 14) hint))))))
+ (define-jump jmp 0)
+ (define-jump jsr 1)
+ (define-jump ret 2)
+ (define-jump jsr-coroutine 3))
+
+
+(macrolet ((define-branch (name op &optional (float nil))
+ `(define-instruction ,name (segment ra target)
+ (:declare (type tn ra)
+ (type label target))
+ (:printer branch ((op ,op)
+ ,@(when float
+ '((ra nil :type 'fp-reg)))))
+ (:emitter
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (emit-branch segment ,op
+ ,@(if float
+ '((fp-reg-tn-encoding ra))
+ '((reg-tn-encoding ra)))
+ (ash (- (label-position target)
+ (+ posn 4))
+ -2))))))))
+ (define-branch br #x30)
+ (define-branch bsr #x34)
+ (define-branch blbc #x38)
+ (define-branch blbs #x3c)
+ (define-branch fbeq #x31 t)
+ (define-branch fbne #x35 t)
+ (define-branch beq #x39)
+ (define-branch bne #x3d)
+ (define-branch fblt #x32 t)
+ (define-branch fbge #x36 t)
+ (define-branch blt #x3a)
+ (define-branch bge #x3e)
+ (define-branch fble #x33 t)
+ (define-branch fbgt #x37 t)
+ (define-branch ble #x3b)
+ (define-branch bgt #x3f))
+
+(macrolet ((define-operate (name op fn)
+ `(define-instruction ,name (segment ra rb rc)
+ (:declare (type tn ra rc)
+ (type (or tn (unsigned-byte 8)) rb))
+ (:printer reg-operate ((op ,op) (fn ,fn)))
+ (:printer lit-operate ((op ,op) (fn ,fn)))
+ ,@(when (and (= op #x11) (= fn #x20))
+ `((:printer reg-operate ((op ,op) (fn ,fn) (ra 31))
+ '('move :tab rb "," rc))
+ (:printer reg-operate ((op ,op) (fn ,fn) (ra 31) (rb 31) (rc 31))
+ '('nop))))
+ (:emitter
+ (etypecase rb
+ (tn
+ (emit-reg-operate segment ,op (reg-tn-encoding ra)
+ (reg-tn-encoding rb) 0 0 ,fn (reg-tn-encoding rc)))
+ (number
+ (emit-lit-operate segment ,op (reg-tn-encoding ra) rb 1 ,fn
+ (reg-tn-encoding rc))))))))
+ (define-operate addl #x10 #x00)
+ (define-operate addl/v #x10 #x40)
+ (define-operate addq #x10 #x20)
+ (define-operate addq/v #x10 #x60)
+ (define-operate cmpule #x10 #x3d)
+ (define-operate cmpbge #x10 #x0f)
+ (define-operate subl #x10 #x09)
+ (define-operate subl/v #x10 #x49)
+ (define-operate subq #x10 #x29)
+ (define-operate subq/v #x10 #x69)
+ (define-operate cmpeq #x10 #x2d)
+ (define-operate cmplt #x10 #x4d)
+ (define-operate cmple #x10 #x6d)
+ (define-operate cmpult #x10 #x1d)
+ (define-operate s4addl #x10 #x02)
+ (define-operate s4addq #x10 #x22)
+ (define-operate s4subl #x10 #x0b)
+ (define-operate s4subq #x10 #x2b)
+ (define-operate s8addl #x10 #x12)
+ (define-operate s8addq #x10 #x32)
+ (define-operate s8subl #x10 #x1b)
+ (define-operate s8subq #x10 #x3b)
+
+ (define-operate and #x11 #x00)
+ (define-operate bic #x11 #x08)
+ (define-operate cmoveq #x11 #x24)
+ (define-operate cmovne #x11 #x26)
+ (define-operate cmovlbs #x11 #x14)
+ (define-operate bis #x11 #x20)
+ (define-operate ornot #x11 #x28)
+ (define-operate cmovlt #x11 #x44)
+ (define-operate cmovge #x11 #x46)
+ (define-operate cmovlbc #x11 #x16)
+ (define-operate xor #x11 #x40)
+ (define-operate eqv #x11 #x48)
+ (define-operate cmovle #x11 #x64)
+ (define-operate cmovgt #x11 #x66)
+
+ (define-operate sll #x12 #x39)
+ (define-operate extbl #x12 #x06)
+ (define-operate extwl #x12 #x16)
+ (define-operate extll #x12 #x26)
+ (define-operate extql #x12 #x36)
+ (define-operate extwh #x12 #x5a)
+ (define-operate extlh #x12 #x6a)
+ (define-operate extqh #x12 #x7a)
+ (define-operate sra #x12 #x3c)
+ (define-operate insbl #x12 #x0b)
+ (define-operate inswl #x12 #x1b)
+ (define-operate insll #x12 #x2b)
+ (define-operate insql #x12 #x3b)
+ (define-operate inswh #x12 #x57)
+ (define-operate inslh #x12 #x67)
+ (define-operate insqh #x12 #x77)
+ (define-operate srl #x12 #x34)
+ (define-operate mskbl #x12 #x02)
+ (define-operate mskwl #x12 #x12)
+ (define-operate mskll #x12 #x22)
+ (define-operate mskql #x12 #x32)
+ (define-operate mskwh #x12 #x52)
+ (define-operate msklh #x12 #x62)
+ (define-operate mskqh #x12 #x72)
+ (define-operate zap #x12 #x30)
+ (define-operate zapnot #x12 #x31)
+
+ (define-operate mull #x13 #x00)
+ (define-operate mulq/v #x13 #x60)
+ (define-operate mull/v #x13 #x40)
+ (define-operate umulh #x13 #x30)
+ (define-operate mulq #x13 #x20))
+
+
+(macrolet ((define-fp-operate (name op fn &optional (args 3))
+ `(define-instruction ,name (segment ,@(when (= args 3) '(fa)) fb fc)
+ (:declare (type tn ,@(when (= args 3) '(fa)) fb fc))
+ (:printer fp-operate ((op ,op) (fn ,fn) ,@(when (= args 2) '((fa 31))))
+ ,@(when (= args 2)
+ '('(:name :tab fb "," fc))))
+ ,@(when (and (= op #x17) (= fn #x20))
+ `((:printer fp-operate ((op ,op) (fn ,fn) (fa 31))
+ '('fabs :tab fb "," fc))))
+ (:emitter
+ (emit-fp-operate segment ,op ,@(if (= args 3)
+ '((fp-reg-tn-encoding fa))
+ '(31))
+ (fp-reg-tn-encoding fb) ,fn (fp-reg-tn-encoding fc))))))
+ (define-fp-operate cpys #x17 #x020)
+ (define-fp-operate mf_fpcr #x17 #x025)
+ (define-fp-operate cpysn #x17 #x021)
+ (define-fp-operate mt_fpcr #x17 #x024)
+ (define-fp-operate cpyse #x17 #x022)
+ (define-fp-operate cvtql/sv #x17 #x530 2)
+ (define-fp-operate cvtlq #x17 #x010 2)
+ (define-fp-operate cvtql #x17 #x030 2)
+ (define-fp-operate cvtql/v #x17 #x130 2)
+ (define-fp-operate fcmoveq #x17 #x02a)
+ (define-fp-operate fcmovne #x17 #x02b)
+ (define-fp-operate fcmovlt #x17 #x02c)
+ (define-fp-operate fcmovge #x17 #x02d)
+ (define-fp-operate fcmovle #x17 #x02e)
+ (define-fp-operate fcmovgt #x17 #x02f)
+
+ (define-fp-operate cvtqs #x16 #x0bc 2)
+ (define-fp-operate cvtqt #x16 #x0be 2)
+ (define-fp-operate cvtts #x16 #x0ac 2)
+ (define-fp-operate cvttq #x16 #x0af 2)
+ (define-fp-operate cvttq/c #x16 #x02f 2)
+ (define-fp-operate cmpteq #x16 #x5a5)
+ (define-fp-operate cmptlt #x16 #x5a6)
+ (define-fp-operate cmptle #x16 #x5a7)
+ (define-fp-operate cmptun #x16 #x5a4)
+ (define-fp-operate adds #x16 #x080)
+ (define-fp-operate addt #x16 #x0a0)
+ (define-fp-operate divs #x16 #x083)
+ (define-fp-operate divt #x16 #x0a3)
+ (define-fp-operate muls #x16 #x082)
+ (define-fp-operate mult #x16 #x0a2)
+ (define-fp-operate subs #x16 #x081)
+ (define-fp-operate subt #x16 #x0a1)
+
+;;; IEEE support
+ (defconstant +su+ #x500) ; software, underflow enabled
+ (defconstant +sui+ #x700) ; software, inexact & underflow enabled
+ (defconstant +sv+ #x500) ; software, interger overflow enabled
+ (defconstant +svi+ #x700)
+ (defconstant +rnd+ #x0c0) ; dynamic rounding mode
+ (defconstant +sud+ #x5c0)
+ (defconstant +svid+ #x7c0)
+ (defconstant +suid+ #x7c0)
+
+ (define-fp-operate cvtqs_su #x16 (logior +su+ #x0bc) 2)
+ (define-fp-operate cvtqt_su #x16 (logior +su+ #x0be) 2)
+ (define-fp-operate cvtts_su #x16 (logior +su+ #x0ac) 2)
+
+ (define-fp-operate adds_su #x16 (logior +su+ #x080))
+ (define-fp-operate addt_su #x16 (logior +su+ #x0a0))
+ (define-fp-operate divs_su #x16 (logior +su+ #x083))
+ (define-fp-operate divt_su #x16 (logior +su+ #x0a3))
+ (define-fp-operate muls_su #x16 (logior +su+ #x082))
+ (define-fp-operate mult_su #x16 (logior +su+ #x0a2))
+ (define-fp-operate subs_su #x16 (logior +su+ #x081))
+ (define-fp-operate subt_su #x16 (logior +su+ #x0a1)))
+
+(define-instruction excb (segment)
+ (:emitter (emit-lword segment #x63ff0400)))
+
+(define-instruction trapb (segment)
+ (:emitter (emit-lword segment #x63ff0000)))
+
+(define-instruction gentrap (segment code)
+ (:printer call-pal ((palcode #xaa0000)))
+ (:emitter
+ (emit-lword segment #x000080)
+ (emit-lword segment code)))
+
+(define-instruction-macro move (src dst)
+ `(inst bis zero-tn ,src ,dst))
+
+(define-instruction-macro not (src dst)
+ `(inst ornot zero-tn ,src ,dst))
+
+(define-instruction-macro fmove (src dst)
+ `(inst cpys ,src ,src ,dst))
+
+(define-instruction-macro fabs (src dst)
+ `(inst cpys fp-single-zero-tn ,src ,dst))
+
+(define-instruction-macro fneg (src dst)
+ `(inst cpysn ,src ,src ,dst))
+
+(define-instruction-macro nop ()
+ `(inst bis zero-tn zero-tn zero-tn))
+
+(defun %li (value reg)
+ (etypecase value
+ ((signed-byte 16)
+ (inst lda reg value zero-tn))
+ ((signed-byte 32)
+ (flet ((se (x n)
+ (let ((x (logand x (lognot (ash -1 n)))))
+ (if (logbitp (1- n) x)
+ (logior (ash -1 (1- n)) x)
+ x))))
+ (let* ((value (se value 32))
+ (low (ldb (byte 16 0) value))
+ (tmp1 (- value (se low 16)))
+ (high (ldb (byte 16 16) tmp1))
+ (tmp2 (- tmp1 (se (ash high 16) 32)))
+ (extra 0))
+ (unless (= tmp2 0)
+ (setf extra #x4000)
+ (setf tmp1 (- tmp1 #x40000000))
+ (setf high (ldb (byte 16 16) tmp1)))
+ (inst lda reg low zero-tn)
+ (unless (= extra 0)
+ (inst ldah reg extra reg))
+ (unless (= high 0)
+ (inst ldah reg high reg)))))
+ ((or (unsigned-byte 32) (signed-byte 64) (unsigned-byte 64))
+ (let* ((value1 (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value2 (if (logbitp 31 value) (+ value (ash 1 32)) value1))
+ (value3 (if (logbitp 47 value) (+ value (ash 1 48)) value2)))
+ (inst lda reg (ldb (byte 16 32) value2) zero-tn)
+ (unless (= value3 0)
+ (inst ldah reg (ldb (byte 16 48) value3) reg))
+ (unless (and (= value2 0) (= value3 0))
+ (inst sll reg 32 reg))
+ (unless (= value 0)
+ (inst lda reg (ldb (byte 16 0) value) reg))
+ (unless (= value1 0)
+ (inst ldah reg (ldb (byte 16 16) value1) reg))))
+ (fixup
+ (inst lda reg value zero-tn :bits-47-32)
+ (inst ldah reg value reg :bits-63-48)
+ (inst sll reg 32 reg)
+ (inst lda reg value reg)
+ (inst ldah reg value reg))))
+
+(define-instruction-macro li (value reg)
+ `(%li ,value ,reg))
+
+\f
+;;;;
+
+(define-instruction lword (segment lword)
+ (:declare (type (or (unsigned-byte 32) (signed-byte 32)) lword))
+ (:cost 0)
+ (:emitter
+ (emit-lword segment lword)))
+
+(define-instruction short (segment word)
+ (:declare (type (or (unsigned-byte 16) (signed-byte 16)) word))
+ (:cost 0)
+ (:emitter
+ (emit-word segment word)))
+
+(define-instruction byte (segment byte)
+ (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
+ (:cost 0)
+ (:emitter
+ (emit-byte segment byte)))
+
+(defun emit-header-data (segment type)
+ (emit-back-patch
+ segment 4
+ #'(lambda (segment posn)
+ (emit-lword segment
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- type-bits word-shift)))))))
+
+(define-instruction function-header-word (segment)
+ (:cost 0)
+ (:emitter
+ (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+ (:cost 0)
+ (:emitter
+ (emit-header-data segment return-pc-header-type)))
+
+(defun emit-compute-inst (segment vop dst src label temp calc)
+ (declare (ignore temp))
+ (emit-chooser
+ ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
+ segment 12 3
+ #'(lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ (when (<= (- (ash 1 15)) delta (1- (ash 1 15)))
+ (emit-back-patch segment 4
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (inst lda dst
+ (funcall calc label posn 0)
+ src))))
+ t)))
+ #'(lambda (segment posn)
+ (assemble (segment vop)
+ (flet ((se (x n)
+ (let ((x (logand x (lognot (ash -1 n)))))
+ (if (logbitp (1- n) x)
+ (logior (ash -1 (1- n)) x)
+ x))))
+ (let* ((value (se (funcall calc label posn 0) 32))
+ (low (ldb (byte 16 0) value))
+ (tmp1 (- value (se low 16)))
+ (high (ldb (byte 16 16) tmp1))
+ (tmp2 (- tmp1 (se (ash high 16) 32)))
+ (extra 0))
+ (unless (= tmp2 0)
+ (setf extra #x4000)
+ (setf tmp1 (- tmp1 #x40000000))
+ (setf high (ldb (byte 16 16) tmp1)))
+ (inst lda dst low src)
+ (inst ldah dst extra dst)
+ (inst ldah dst high dst)))))))
+
+;; code = fn - header - label-offset + other-pointer-tag
+(define-instruction compute-code-from-fn (segment dst src label temp)
+ (:declare (type tn dst src temp) (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop dst src label temp
+ #'(lambda (label posn delta-if-after)
+ (- other-pointer-type
+ (label-position label posn delta-if-after)
+ (component-header-length))))))
+
+;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
+;; = lra - (header + label-offset)
+(define-instruction compute-code-from-lra (segment dst src label temp)
+ (:declare (type tn dst src temp) (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop dst src label temp
+ #'(lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))))
+
+;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
+(define-instruction compute-lra-from-code (segment dst src label temp)
+ (:declare (type tn dst src temp) (type label label))
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop dst src label temp
+ #'(lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length))))))
--- /dev/null
+;;; -*- Package: ALPHA; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains various useful macros for generating Alpha code.
+;;;
+;;; Written by William Lott and Christopher Hoover.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+;;; Handy macro for defining top-level forms that depend on the compile
+;;; environment.
+
+(defmacro expand (expr)
+ (let ((gensym (gensym)))
+ `(macrolet
+ ((,gensym ()
+ ,expr))
+ (,gensym))))
+
+\f
+;;; Instruction-like macros.
+
+;;; c.f. x86 backend:
+;;(defmacro move (dst src)
+;; #!+sb-doc
+;; "Move SRC into DST unless they are location=."
+;; (once-only ((n-dst dst)
+;; (n-src src))
+;; `(unless (location= ,n-dst ,n-src)
+;; (inst mov ,n-dst ,n-src))))
+
+
+(defmacro move (src dst)
+ "Move SRC into DST unless they are location=."
+ (once-only ((n-src src) (n-dst dst))
+ `(unless (location= ,n-src ,n-dst)
+ (inst move ,n-src ,n-dst))))
+
+(defmacro loadw (result base &optional (offset 0) (lowtag 0))
+ (once-only ((result result) (base base))
+ `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro loadq (result base &optional (offset 0) (lowtag 0))
+ (once-only ((result result) (base base))
+ `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro storew (value base &optional (offset 0) (lowtag 0))
+ (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+ `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro storeq (value base &optional (offset 0) (lowtag 0))
+ (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
+ `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
+
+(defmacro load-symbol (reg symbol)
+ (once-only ((reg reg) (symbol symbol))
+ `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
+
+(defmacro load-symbol-value (reg symbol)
+ `(inst ldl ,reg
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type))
+ null-tn))
+
+(defmacro store-symbol-value (reg symbol)
+ `(inst stl ,reg
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type))
+ null-tn))
+
+(defmacro load-type (target source &optional (offset 0))
+ "Loads the type bits of a pointer into target independent of
+ byte-ordering issues."
+ (once-only ((n-target target)
+ (n-source source)
+ (n-offset offset))
+ `(progn
+ (inst ldl ,n-target ,n-offset ,n-source)
+ (inst and ,n-target #xff ,n-target))))
+
+;;; Macros to handle the fact that we cannot use the machine native call and
+;;; return instructions.
+
+(defmacro lisp-jump (function lip)
+ "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
+ `(progn
+ (inst lda ,lip (- (ash sb!vm:function-code-offset sb!vm:word-shift)
+ sb!vm:function-pointer-type)
+ ,function)
+ (move ,function code-tn)
+ (inst jsr zero-tn ,lip 1)))
+
+(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+ "Return to RETURN-PC. LIP is an interior-reg temporary."
+ `(progn
+ (inst lda ,lip
+ (- (* (1+ ,offset) word-bytes) other-pointer-type)
+ ,return-pc)
+ ,@(when frob-code
+ `((move ,return-pc code-tn)))
+ (inst ret zero-tn ,lip 1)))
+
+
+(defmacro emit-return-pc (label)
+ "Emit a return-pc header word. LABEL is the label to use for this
+ return-pc."
+ `(progn
+ (align lowtag-bits)
+ (emit-label ,label)
+ (inst lra-header-word)))
+
+
+\f
+;;;; Stack TN's
+
+;;; Load-Stack-TN, Store-Stack-TN -- Interface
+;;;
+;;; Move a stack TN to a register and vice-versa.
+;;;
+(defmacro load-stack-tn (reg stack)
+ `(let ((reg ,reg)
+ (stack ,stack))
+ (let ((offset (tn-offset stack)))
+ (sc-case stack
+ ((control-stack)
+ (loadw reg cfp-tn offset))))))
+
+(defmacro store-stack-tn (stack reg)
+ `(let ((stack ,stack)
+ (reg ,reg))
+ (let ((offset (tn-offset stack)))
+ (sc-case stack
+ ((control-stack)
+ (storew reg cfp-tn offset))))))
+
+
+;;; MAYBE-LOAD-STACK-TN -- Interface
+;;;
+(defmacro maybe-load-stack-tn (reg reg-or-stack)
+ "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+ (once-only ((n-reg reg)
+ (n-stack reg-or-stack))
+ `(sc-case ,n-reg
+ ((any-reg descriptor-reg)
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-stack ,n-reg))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
+
+;;; MAYBE-LOAD-STACK-NFP-TN -- Interface
+;;;
+(defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
+ "Move the TN Reg-Or-Stack into Reg if it isn't already there."
+ (once-only ((n-reg reg)
+ (n-stack reg-or-stack))
+ `(when ,reg
+ (sc-case ,n-reg
+ ((any-reg descriptor-reg)
+ (sc-case ,n-stack
+ ((any-reg descriptor-reg)
+ (move ,n-stack ,n-reg))
+ ((control-stack)
+ (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
+ (inst mskll nsp-tn 0 ,temp)
+ (inst bis ,temp ,n-reg ,n-reg))))))))
+
+
+\f
+;;;; Storage allocation:
+
+(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
+ &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
+ Result-TN, Flag-Tn must be wired to NL3-OFFSET, and Temp-TN is a non-
+ descriptor temp (which may be randomly used by the body.) The body is
+ placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
+ `(pseudo-atomic (:extra (pad-data-block ,size))
+ (inst bis alloc-tn other-pointer-type ,result-tn)
+ (inst li (logior (ash (1- ,size) type-bits) ,type-code) ,temp-tn)
+ (storew ,temp-tn ,result-tn 0 other-pointer-type)
+ ,@body))
+
+
+\f
+;;;; Error Code
+
+
+(defvar *adjustable-vectors* nil)
+
+(defmacro with-adjustable-vector ((var) &rest body)
+ `(let ((,var (or (pop *adjustable-vectors*)
+ (make-array 16
+ :element-type '(unsigned-byte 8)
+ :fill-pointer 0
+ :adjustable t))))
+ (setf (fill-pointer ,var) 0)
+ (unwind-protect
+ (progn
+ ,@body)
+ (push ,var *adjustable-vectors*))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun emit-error-break (vop kind code values)
+ (let ((vector (gensym)))
+ `((let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst gentrap ,kind)
+ (with-adjustable-vector (,vector)
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar #'(lambda (tn)
+ `(let ((tn ,tn))
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (tn-offset tn))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))
+ (align word-shift)))))
+
+(defmacro error-call (vop error-code &rest values)
+ "Cause an error. ERROR-CODE is the error to cause."
+ (cons 'progn
+ (emit-error-break vop error-trap error-code values)))
+
+
+(defmacro cerror-call (vop label error-code &rest values)
+ "Cause a continuable error. If the error is continued, execution resumes at
+ LABEL."
+ `(progn
+ (inst br zero-tn ,label)
+ ,@(emit-error-break vop cerror-trap error-code values)))
+
+(defmacro generate-error-code (vop error-code &rest values)
+ "Generate-Error-Code Error-code Value*
+ Emit code for an error with the specified Error-Code and context Values."
+ `(assemble (*elsewhere*)
+ (let ((start-lab (gen-label)))
+ (emit-label start-lab)
+ (error-call ,vop ,error-code ,@values)
+ start-lab)))
+
+(defmacro generate-cerror-code (vop error-code &rest values)
+ "Generate-CError-Code Error-code Value*
+ Emit code for a continuable error with the specified Error-Code and
+ context Values. If the error is continued, execution resumes after
+ the GENERATE-CERROR-CODE form."
+ (let ((continue (gensym "CONTINUE-LABEL-"))
+ (error (gensym "ERROR-LABEL-")))
+ `(let ((,continue (gen-label)))
+ (emit-label ,continue)
+ (assemble (*elsewhere*)
+ (let ((,error (gen-label)))
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values)
+ ,error)))))
+
+\f
+;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
+;;;
+(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
+ `(progn
+ (inst addq alloc-tn 1 alloc-tn)
+ ,@forms
+ (inst lda alloc-tn (1- ,extra) alloc-tn)
+ (inst stl zero-tn 0 alloc-tn)))
+
+
+\f
+;;;; Memory accessor vop generators
+
+(deftype load/store-index (scale lowtag min-offset
+ &optional (max-offset min-offset))
+ `(integer ,(- (truncate (+ (ash 1 16)
+ (* min-offset word-bytes)
+ (- lowtag))
+ scale))
+ ,(truncate (- (+ (1- (ash 1 16)) lowtag)
+ (* max-offset word-bytes))
+ scale)))
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type
+ &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types ,type tagged-num)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst addq object index lip)
+ (inst ldl value (- (* ,offset word-bytes) ,lowtag) lip)
+ ,@(when (equal scs '(unsigned-reg))
+ '((inst mskll value 4 value)))))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,word-bytes ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4
+ (inst ldl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+ object)
+ ,@(when (equal scs '(unsigned-reg))
+ '((inst mskll value 4 value)))))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type
+ &optional translate #+gengc (remember t))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type tagged-num ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 2
+ (inst addq index object lip)
+ (inst stl value (- (* ,offset word-bytes) ,lowtag) lip)
+ (move value result)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,word-bytes ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 1
+ (inst stl value (- (* (+ ,offset index) word-bytes) ,lowtag)
+ object)
+ (move value result)))))
+
+
+(defmacro define-partial-reffer (name type size signed offset lowtag scs
+ el-type &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:generator 5
+ (inst addq object index lip)
+ ,@(when (eq size :short)
+ '((inst addq index lip lip)))
+ ,@(ecase size
+ (:byte
+ (if signed
+ `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+ lip)
+ (inst lda temp1 (1+ (- (* ,offset word-bytes) ,lowtag))
+ lip)
+ (inst extqh temp temp1 temp)
+ (inst sra temp 56 value))
+ `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+ lip)
+ (inst extbl temp temp1 value))))
+ (:short
+ (if signed
+ `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+ lip)
+ (inst lda temp1 (- (* ,offset word-bytes) ,lowtag)
+ lip)
+ (inst extwl temp temp1 temp)
+ (inst sll temp 48 temp)
+ (inst sra temp 48 value))
+ `((inst ldq_u temp (- (* ,offset word-bytes) ,lowtag)
+ lip)
+ (inst lda temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst extwl temp temp1 value)))))))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset))))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:generator 5
+ ,@(ecase size
+ (:byte
+ (if signed
+ `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (1+ (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag))
+ object)
+ (inst extqh temp temp1 temp)
+ (inst sra temp 56 value))
+ `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst extbl temp temp1 value))))
+ (:short
+ (if signed
+ `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst extwl temp temp1 temp)
+ (inst sll temp 48 temp)
+ (inst sra temp 48 value))
+ `((inst ldq_u temp (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst lda temp1 (- (+ (* ,offset word-bytes)
+ (* index ,scale)) ,lowtag)
+ object)
+ (inst extwl temp temp1 value))))))))))
+
+(defmacro define-partial-setter (name type size offset lowtag scs el-type
+ &optional translate)
+ (let ((scale (ecase size (:byte 1) (:short 2))))
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type positive-fixnum ,el-type)
+ (:temporary (:scs (interior-reg)) lip)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:temporary (:sc non-descriptor-reg) temp2)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ (inst addq object index lip)
+ ,@(when (eq size :short)
+ '((inst addq lip index lip)))
+ ,@(ecase size
+ (:byte
+ `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst insbl value temp temp2)
+ (inst mskbl temp1 temp temp1)
+ (inst bis temp1 temp2 temp1)
+ (inst stq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)))
+ (:short
+ `((inst lda temp (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst ldq_u temp1 (- (* ,offset word-bytes) ,lowtag) lip)
+ (inst mskwl temp1 temp temp1)
+ (inst inswl value temp temp2)
+ (inst bis temp1 temp2 temp)
+ (inst stq_u temp (- (* ,offset word-bytes) ,lowtag) lip))))
+ (move value result)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type
+ (:constant (load/store-index ,scale
+ ,(eval lowtag)
+ ,(eval offset)))
+ ,el-type)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:temporary (:sc non-descriptor-reg) temp2)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 5
+ ,@(ecase size
+ (:byte
+ `((inst lda temp (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst ldq_u temp1 (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst insbl value temp temp2)
+ (inst mskbl temp1 temp temp1)
+ (inst bis temp1 temp2 temp1)
+ (inst stq_u temp1 (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag) object)))
+ (:short
+ `((inst lda temp (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst ldq_u temp1 (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag)
+ object)
+ (inst mskwl temp1 temp temp1)
+ (inst inswl value temp temp2)
+ (inst bis temp1 temp2 temp)
+ (inst stq_u temp (- (* ,offset word-bytes)
+ (* index ,scale) ,lowtag) object))))
+ (move value result))))))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the Alpha definitions of some general purpose memory
+;;; reference VOPs inherited by basic memory reference operations.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+
+;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the offset to
+;;; be read or written is a property of the VOP used.
+;;;
+(define-vop (cell-ref)
+ (:args (object :scs (descriptor-reg)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (loadw value object offset lowtag)))
+;;;
+(define-vop (cell-set)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg null zero)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (storew value object offset lowtag)))
+
+;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
+;;; offset is constant at compile time, but varies for different uses. We add
+;;; in the stardard g-vector overhead.
+;;;
+(define-vop (slot-ref)
+ (:args (object :scs (descriptor-reg)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (loadw value object (+ base offset) lowtag)))
+;;;
+(define-vop (slot-set)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg null zero)))
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (storew value object (+ base offset) lowtag)))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the MIPS VM definition of operand loading/saving and
+;;; the Move VOP.
+;;;
+;;; Written by Rob MacLachlan.
+;;; Conversion by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+
+(define-move-function (load-immediate 1) (vop x y)
+ ((null zero immediate)
+ (any-reg descriptor-reg))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (inst li (fixnumize val) y))
+ (null
+ (move null-tn y))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst li (logior (ash (char-code val) type-bits) base-char-type)
+ y)))))
+
+(define-move-function (load-number 1) (vop x y)
+ ((zero immediate)
+ (signed-reg unsigned-reg))
+ (inst li (tn-value x) y))
+
+(define-move-function (load-base-char 1) (vop x y)
+ ((immediate) (base-char-reg))
+ (inst li (char-code (tn-value x)) y))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+ ((immediate) (sap-reg))
+ (inst li (sap-int (tn-value x)) y))
+
+(define-move-function (load-constant 5) (vop x y)
+ ((constant) (descriptor-reg any-reg))
+ (loadw y code-tn (tn-offset x) other-pointer-type))
+
+(define-move-function (load-stack 5) (vop x y)
+ ((control-stack) (any-reg descriptor-reg))
+ (load-stack-tn y x))
+
+(define-move-function (load-number-stack 5) (vop x y)
+ ((base-char-stack) (base-char-reg))
+ (let ((nfp (current-nfp-tn vop)))
+ (loadw y nfp (tn-offset x))))
+
+(define-move-function (load-number-stack-64 5) (vop x y)
+ ((sap-stack) (sap-reg)
+ (signed-stack) (signed-reg)
+ (unsigned-stack) (unsigned-reg))
+ (let ((nfp (current-nfp-tn vop)))
+ (loadq y nfp (tn-offset x))))
+
+(define-move-function (store-stack 5) (vop x y)
+ ((any-reg descriptor-reg null zero) (control-stack))
+ (store-stack-tn y x))
+
+(define-move-function (store-number-stack 5) (vop x y)
+ ((base-char-reg) (base-char-stack))
+ (let ((nfp (current-nfp-tn vop)))
+ (storew x nfp (tn-offset y))))
+
+(define-move-function (store-number-stack-64 5) (vop x y)
+ ((sap-reg) (sap-stack)
+ (signed-reg) (signed-stack)
+ (unsigned-reg) (unsigned-stack))
+ (let ((nfp (current-nfp-tn vop)))
+ (storeq x nfp (tn-offset y))))
+
+\f
+;;;; The Move VOP:
+;;;
+(define-vop (move)
+ (:args (x :target y
+ :scs (any-reg descriptor-reg zero null)
+ :load-if (not (location= x y))))
+ (:results (y :scs (any-reg descriptor-reg control-stack)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (unless (location= x y)
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (inst move x y))
+ (control-stack
+ (store-stack-tn y x))))))
+
+(define-move-vop move :move
+ (any-reg descriptor-reg zero null)
+ (any-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation doesn't think
+;;; it is a hairy type. This also allows checking of a few of the values in a
+;;; continuation to fall out.
+;;;
+(primitive-type-vop move (:check) t)
+
+;;; The Move-Argument VOP is used for moving descriptor values into another
+;;; frame for argument or known value passing.
+;;;
+(define-vop (move-argument)
+ (:args (x :target y
+ :scs (any-reg descriptor-reg null zero))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (move x y))
+ (control-stack
+ (storew x fp (tn-offset y))))))
+;;;
+(define-move-vop move-argument :move-argument
+ (any-reg descriptor-reg null zero)
+ (any-reg descriptor-reg))
+
+
+\f
+;;;; ILLEGAL-MOVE
+
+;;; This VOP exists just to begin the lifetime of a TN that couldn't be written
+;;; legally due to a type error. An error is signalled before this VOP is
+;;; so we don't need to do anything (not that there would be anything sensible
+;;; to do anyway.)
+;;;
+(define-vop (illegal-move)
+ (:args (x) (type))
+ (:results (y))
+ (:ignore y)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 666
+ (error-call vop object-not-type-error x type)))
+
+
+\f
+;;;; Moves and coercions:
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw integer
+;;; to a tagged bignum or fixnum.
+
+;;; Arg is a fixnum, so just shift it. We need a type restriction because some
+;;; possible arg SCs (control-stack) overlap with possible bignum arg SCs.
+;;;
+(define-vop (move-to-word/fixnum)
+ (:args (x :scs (any-reg descriptor-reg)))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:arg-types tagged-num)
+ (:note "fixnum untagging")
+ (:generator 1
+ (inst sra x 2 y)))
+;;;
+(define-move-vop move-to-word/fixnum :move
+ (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-word-c)
+ (:args (x :scs (constant)))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:note "constant load")
+ (:generator 1
+ (inst li (tn-value x) y)))
+;;;
+(define-move-vop move-to-word-c :move
+ (constant) (signed-reg unsigned-reg))
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:note "integer to untagged word coercion")
+ (:temporary (:sc non-descriptor-reg) header)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 3
+ (inst and x 3 temp)
+ (inst sra x 2 y)
+ (inst beq temp done)
+
+ (loadw header x 0 other-pointer-type)
+ (inst srl header (1+ type-bits) header)
+ (loadw y x bignum-digits-offset other-pointer-type)
+ (inst beq header one)
+
+ (loadw header x (1+ bignum-digits-offset) other-pointer-type)
+ (inst sll header 32 header)
+ (inst mskll y 4 y)
+ (inst bis header y y)
+ (inst br zero-tn done)
+ ONE
+ (when (sc-is y unsigned-reg)
+ (inst mskll y 4 y))
+ DONE))
+;;;
+(define-move-vop move-to-word/integer :move
+ (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; Result is a fixnum, so we can just shift. We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+;;;
+(define-vop (move-from-word/fixnum)
+ (:args (x :scs (signed-reg unsigned-reg)))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:result-types tagged-num)
+ (:note "fixnum tagging")
+ (:generator 1
+ (inst sll x 2 y)))
+;;;
+(define-move-vop move-from-word/fixnum :move
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check. Use a worst-case cost to make
+;;; sure people know they may be number consing.
+;;;
+(define-vop (move-from-signed)
+ (:args (arg :scs (signed-reg unsigned-reg) :target x))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+ (:temporary (:sc non-descriptor-reg) header)
+ (:note "signed word to integer coercion")
+ (:generator 18
+ (move arg x)
+ (inst sra x 29 temp)
+ (inst sll x 2 y)
+ (inst beq temp done)
+ (inst not temp temp)
+ (inst beq temp done)
+
+ (inst li 2 header)
+ (inst sra x 31 temp)
+ (inst cmoveq temp 1 header)
+ (inst not temp temp)
+ (inst cmoveq temp 1 header)
+ (inst sll header type-bits header)
+ (inst bis header bignum-type header)
+
+ (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+ (inst bis alloc-tn other-pointer-type y)
+ (storew header y 0 other-pointer-type)
+ (storew x y bignum-digits-offset other-pointer-type)
+ (inst srl x 32 temp)
+ (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+ DONE))
+
+;;;
+(define-move-vop move-from-signed :move
+ (signed-reg) (descriptor-reg))
+
+
+;;; Check for fixnum, and possibly allocate one or two word bignum result. Use
+;;; a worst-case cost to make sure people know they may be number consing.
+;;;
+(define-vop (move-from-unsigned)
+ (:args (arg :scs (signed-reg unsigned-reg) :target x))
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:note "unsigned word to integer coercion")
+ (:generator 20
+ (move arg x)
+ (inst srl x 29 temp)
+ (inst sll x 2 y)
+ (inst beq temp done)
+
+ (inst li 3 temp)
+ (inst cmovge x 2 temp)
+ (inst srl x 31 temp1)
+ (inst cmoveq temp1 1 temp)
+ (inst sll temp type-bits temp)
+ (inst bis temp bignum-type temp)
+
+ (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
+ (inst bis alloc-tn other-pointer-type y)
+ (storew temp y 0 other-pointer-type)
+ (storew x y bignum-digits-offset other-pointer-type)
+ (inst srl x 32 temp)
+ (storew temp y (1+ bignum-digits-offset) other-pointer-type))
+ DONE))
+
+;;;
+(define-move-vop move-from-unsigned :move
+ (unsigned-reg) (descriptor-reg))
+
+
+;;; Move untagged numbers.
+;;;
+(define-vop (word-move)
+ (:args (x :target y
+ :scs (signed-reg unsigned-reg)
+ :load-if (not (location= x y))))
+ (:results (y :scs (signed-reg unsigned-reg)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:note "word integer move")
+ (:generator 0
+ (move x y)))
+;;;
+(define-move-vop word-move :move
+ (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Move untagged number arguments/return-values.
+;;;
+(define-vop (move-word-argument)
+ (:args (x :target y
+ :scs (signed-reg unsigned-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:note "word integer argument move")
+ (:generator 0
+ (sc-case y
+ ((signed-reg unsigned-reg)
+ (move x y))
+ ((signed-stack unsigned-stack)
+ (storeq x fp (tn-offset y))))))
+;;;
+(define-move-vop move-word-argument :move-argument
+ (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged number to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the definitions of VOPs used for non-local exit
+;;; (throw, lexical exit, etc.)
+;;;
+;;; Written by Rob MacLachlan
+;;; Conversion by Sean Hallgren
+;;;
+(in-package "SB!VM")
+
+
+;;; MAKE-NLX-SP-TN -- Interface
+;;;
+;;; Make an environment-live stack TN for saving the SP for NLX entry.
+;;;
+(!def-vm-support-routine make-nlx-sp-tn (env)
+ (environment-live-tn
+ (make-representation-tn *fixnum-primitive-type* immediate-arg-scn)
+ env))
+
+;;; Make-NLX-Entry-Argument-Start-Location -- Interface
+;;;
+;;; Make a TN for the argument count passing location for a
+;;; non-local entry.
+;;;
+(!def-vm-support-routine make-nlx-entry-argument-start-location ()
+ (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset))
+
+\f
+;;; Save and restore dynamic environment.
+;;;
+;;; These VOPs are used in the reentered function to restore the appropriate
+;;; dynamic environment. Currently we only save the Current-Catch and binding
+;;; stack pointer. We don't need to save/restore the current unwind-protect,
+;;; since unwind-protects are implicitly processed during unwinding. If there
+;;; were any additional stacks, then this would be the place to restore the top
+;;; pointers.
+
+
+;;; Make-Dynamic-State-TNs -- Interface
+;;;
+;;; Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+;;;
+(!def-vm-support-routine make-dynamic-state-tns ()
+ (list (make-normal-tn *backend-t-primitive-type*)
+ (make-normal-tn *backend-t-primitive-type*)
+ (make-normal-tn *backend-t-primitive-type*)
+ (make-normal-tn *backend-t-primitive-type*)))
+
+(define-vop (save-dynamic-state)
+ (:results (catch :scs (descriptor-reg))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg))
+ (eval :scs (descriptor-reg)))
+ (:vop-var vop)
+ (:generator 13
+ (load-symbol-value catch sb!impl::*current-catch-block*)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst mskll cur-nfp 4 nfp)))
+ (inst mskll nsp-tn 4 nsp)
+ (load-symbol-value eval sb!impl::*eval-stack-top*)))
+
+(define-vop (restore-dynamic-state)
+ (:args (catch :scs (descriptor-reg))
+ (nfp :scs (descriptor-reg))
+ (nsp :scs (descriptor-reg))
+ (eval :scs (descriptor-reg)))
+ (:vop-var vop)
+ (:temporary (:sc any-reg) temp)
+ (:generator 10
+ (store-symbol-value catch sb!impl::*current-catch-block*)
+ (store-symbol-value eval sb!impl::*eval-stack-top*)
+ (inst mskll nsp-tn 0 temp)
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (when cur-nfp
+ (inst bis nfp temp cur-nfp)))
+ (inst bis nsp temp nsp-tn)))
+
+(define-vop (current-stack-pointer)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (move csp-tn res)))
+
+(define-vop (current-binding-pointer)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (move bsp-tn res)))
+
+
+\f
+;;;; Unwind block hackery:
+
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+;;;
+(define-vop (make-unwind-block)
+ (:args (tn))
+ (:info entry-label)
+ (:results (block :scs (any-reg)))
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:generator 22
+ (inst lda block (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
+ (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
+ (storew temp block sb!vm:unwind-block-current-uwp-slot)
+ (storew cfp-tn block sb!vm:unwind-block-current-cont-slot)
+ (storew code-tn block sb!vm:unwind-block-current-code-slot)
+ (inst compute-lra-from-code temp code-tn entry-label ndescr)
+ (storew temp block sb!vm:catch-block-entry-pc-slot)))
+
+
+;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+;;;
+(define-vop (make-catch-block)
+ (:args (tn)
+ (tag :scs (descriptor-reg)))
+ (:info entry-label)
+ (:results (block :scs (any-reg)))
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg) :target block :to (:result 0)) result)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:generator 44
+ (inst lda result (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
+ (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
+ (storew temp result sb!vm:catch-block-current-uwp-slot)
+ (storew cfp-tn result sb!vm:catch-block-current-cont-slot)
+ (storew code-tn result sb!vm:catch-block-current-code-slot)
+ (inst compute-lra-from-code temp code-tn entry-label ndescr)
+ (storew temp result sb!vm:catch-block-entry-pc-slot)
+
+ (storew tag result sb!vm:catch-block-tag-slot)
+ (load-symbol-value temp sb!impl::*current-catch-block*)
+ (storew temp result sb!vm:catch-block-previous-catch-slot)
+ (store-symbol-value result sb!impl::*current-catch-block*)
+
+ (move result block)))
+
+
+;;; Just set the current unwind-protect to TN's address. This instantiates an
+;;; unwind block as an unwind-protect.
+;;;
+(define-vop (set-unwind-protect)
+ (:args (tn))
+ (:temporary (:scs (descriptor-reg)) new-uwp)
+ (:generator 7
+ (inst lda new-uwp (* (tn-offset tn) sb!vm:word-bytes) cfp-tn)
+ (store-symbol-value new-uwp sb!impl::*current-unwind-protect-block*)))
+
+
+(define-vop (unlink-catch-block)
+ (:temporary (:scs (any-reg)) block)
+ (:policy :fast-safe)
+ (:translate %catch-breakup)
+ (:generator 17
+ (load-symbol-value block sb!impl::*current-catch-block*)
+ (loadw block block sb!vm:catch-block-previous-catch-slot)
+ (store-symbol-value block sb!impl::*current-catch-block*)))
+
+(define-vop (unlink-unwind-protect)
+ (:temporary (:scs (any-reg)) block)
+ (:policy :fast-safe)
+ (:translate %unwind-protect-breakup)
+ (:generator 17
+ (load-symbol-value block sb!impl::*current-unwind-protect-block*)
+ (loadw block block sb!vm:unwind-block-current-uwp-slot)
+ (store-symbol-value block sb!impl::*current-unwind-protect-block*)))
+
+\f
+;;;; NLX entry VOPs:
+
+
+(define-vop (nlx-entry)
+ (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
+ ; would be inserted before the LRA.
+ (start)
+ (count))
+ (:results (values :more t))
+ (:temporary (:scs (descriptor-reg)) move-temp)
+ (:temporary (:sc non-descriptor-reg) temp)
+ (:info label nvals)
+ (:save-p :force-to-stack)
+ (:vop-var vop)
+ (:generator 30
+ (emit-return-pc label)
+ (note-this-location vop :non-local-entry)
+ (cond ((zerop nvals))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (move null-tn (tn-ref-tn values))
+ (inst beq count no-values)
+ (loadw (tn-ref-tn values) start)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (do ((i 0 (1+ i))
+ (tn-ref values (tn-ref-across tn-ref)))
+ ((null tn-ref))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn tn-ref)))
+ (defaults (cons default-lab tn))
+
+ (inst move count temp)
+ (inst lda count (fixnumize -1) count)
+ (inst beq temp default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start i))
+ (control-stack
+ (loadw move-temp start i)
+ (store-stack-tn tn move-temp)))))
+
+ (let ((defaulting-done (gen-label)))
+
+ (emit-label defaulting-done)
+
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (let ((tn (cdr def)))
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (move null-tn tn))
+ (control-stack
+ (store-stack-tn tn null-tn)))))
+ (inst br zero-tn defaulting-done))))))
+ (load-stack-tn csp-tn sp)))
+
+
+(define-vop (nlx-entry-multiple)
+ (:args (top :target dst) (start :target src) (count :target num))
+ ;; Again, no SC restrictions for the args, 'cause the loading would
+ ;; happen before the entry label.
+ (:info label)
+ (:temporary (:scs (any-reg) :from (:argument 0)) dst)
+ (:temporary (:scs (any-reg) :from (:argument 1)) src)
+ (:temporary (:scs (any-reg) :from (:argument 2)) num)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:results (new-start) (new-count))
+ (:save-p :force-to-stack)
+ (:vop-var vop)
+ (:generator 30
+ (emit-return-pc label)
+ (note-this-location vop :non-local-entry)
+ (let ((loop (gen-label))
+ (done (gen-label)))
+
+ ;; Copy args.
+ (load-stack-tn dst top)
+ (move start src)
+ (move count num)
+
+ ;; Establish results.
+ (sc-case new-start
+ (any-reg (move dst new-start))
+ (control-stack (store-stack-tn new-start dst)))
+ (sc-case new-count
+ (any-reg (inst move num new-count))
+ (control-stack (store-stack-tn new-count num)))
+ (inst beq num done)
+
+ ;; Copy stuff on stack.
+ (emit-label loop)
+ (loadw temp src)
+ (inst lda src sb!vm:word-bytes src)
+ (storew temp dst)
+ (inst lda num (fixnumize -1) num)
+ (inst lda dst sb!vm:word-bytes dst)
+ (inst bne num loop)
+
+ (emit-label done)
+ (inst move dst csp-tn))))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+;;;
+(define-vop (uwp-entry)
+ (:info label)
+ (:save-p :force-to-stack)
+ (:results (block) (start) (count))
+ (:ignore block start count)
+ (:vop-var vop)
+ (:generator 0
+ (emit-return-pc label)
+ (note-this-location vop :non-local-entry)))
--- /dev/null
+
+(in-package "SB!VM")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant word-bits 32
+ #!+sb-doc
+ "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+ #!+sb-doc
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+ #!+sb-doc
+ "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+ #!+sb-doc
+ "Number of bytes in a word.")
+
+(defconstant float-sign-shift 31)
+
+(defconstant single-float-bias 126)
+(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp)
+(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp)
+(defconstant single-float-normal-exponent-min 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(defconstant double-float-bias 1022)
+(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp)
+(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp)
+(defconstant double-float-normal-exponent-min 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant single-float-digits
+ (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+ (+ (byte-size double-float-significand-byte) word-bits 1))
+
+;; Values in 17f code seem to be same as HPPA. These values are from
+;; DEC Assembly Language Programmers guide. The active bits are
+;; actually in (byte 12 52) of the fpcr. (byte 6 52) contain the
+;; exception flags. Bit 63 is the bitwise logor of all exceptions.
+;; The enable and exception bytes are in a software control word
+;; manipulated via OS functions and the bits in the SCP match those
+;; defs. This mapping follows <machine/fpu.h>
+(defconstant float-inexact-trap-bit (ash 1 4)) ; rw
+(defconstant float-underflow-trap-bit (ash 1 3)) ; rw
+(defconstant float-overflow-trap-bit (ash 1 2)) ; ro
+(defconstant float-divide-by-zero-trap-bit (ash 1 1)) ; ro
+(defconstant float-invalid-trap-bit (ash 1 0)) ; ro
+
+(defconstant float-round-to-zero 0)
+(defconstant float-round-to-negative 1)
+(defconstant float-round-to-nearest 2)
+(defconstant float-round-to-positive 3)
+
+;; These aren't quite correct yet. Work in progress.
+(defconstant-eqx float-rounding-mode (byte 2 58) #'equalp) ; hardware fpcr
+(defconstant-eqx float-exceptions-byte (byte 6 52) #'equalp) ; hardware fpcr
+(defconstant-eqx float-sticky-bits (byte 6 17) #'equalp) ; software (clear only)
+(defconstant-eqx float-traps-byte (byte 6 1) #'equalp) ; software fp control word
+(defconstant float-condition-bit (ash 1 63)) ; summary - not used?? XXX
+(defconstant float-fast-bit 0)
+
+); eval-when
+
+
+\f
+;;;; Description of the target address space.
+
+;;; Where to put the different spaces.
+;;;
+
+#!+linux
+(progn
+ (defconstant read-only-space-start #x20000000)
+ (defconstant read-only-space-end #x24000000)
+
+ (defconstant static-space-start #x28000000)
+ (defconstant static-space-end #x2c000000)
+
+ ;; this is used in purify as part of a sloppy check to see if a pointer
+ ;; is in dynamic space. Chocolate brownie for the first person to fix it
+ ;; -dan 20010502
+ (defconstant dynamic-space-start #x30000000)
+ (defconstant dynamic-space-end #x38000000)
+
+ (defconstant dynamic-0-space-start #x30000000)
+ (defconstant dynamic-0-space-end #x38000000)
+
+ (defconstant dynamic-1-space-start #x40000000)
+ (defconstant dynamic-1-space-end #x48000000)
+
+ (defconstant control-stack-start #x50000000)
+ (defconstant control-stack-end #x51000000)
+
+ (defconstant binding-stack-start #x70000000)
+ (defconstant binding-stack-end #x71000000))
+
+#!+osf1 ;as if
+(progn
+ (defparameter read-only-space-start #x10000000)
+ (defparameter static-space-start #x28000000)
+ (defparameter dynamic-space-start #x30000000))
+
+
+;;; FIXME nothing refers to either of these in alpha or x86 cmucl
+;;; backend, so they could probably be removed.
+
+;; The space-register holding the lisp heap.
+(defconstant lisp-heap-space 4)
+
+;; The space-register holding the C text segment.
+(defconstant c-text-space 4)
+
+;;; the X86 port defines *nil-value* as (+ *target-static-space-start* #xB)
+;;; here, but it seems to be the only port that needs to know the
+;;; location of NIL from lisp.
+
+
+\f
+;;;; Other random constants.
+
+(defenum (:suffix -trap :start 8)
+ halt
+ pending-interrupt
+ error
+ cerror
+ breakpoint
+ function-end-breakpoint
+ single-step-breakpoint)
+
+(defenum (:prefix trace-table-)
+ normal
+ call-site
+ function-prologue
+ function-epilogue)
+
+
+\f
+;;;; Static symbols.
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols. That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+(defparameter *static-symbols*
+ '(t
+
+ ;; The C startup code must fill these in.
+ *posix-argv*
+ ;;lisp::lisp-environment-list
+ ;;lisp::lisp-command-line-list
+ sb!impl::*!initial-fdefn-objects*
+
+ ;; Functions that the C code needs to call
+ sb!impl::%initial-function
+ sb!impl::maybe-gc
+ sb!kernel::internal-error
+ sb!di::handle-breakpoint
+ sb!di::handle-function-end-breakpoint
+ sb!impl::fdefinition-object
+
+ ;; Free Pointers.
+ *read-only-space-free-pointer*
+ *static-space-free-pointer*
+ *initial-dynamic-space-free-pointer*
+
+ ;; Things needed for non-local-exit.
+ sb!impl::*current-catch-block*
+ sb!impl::*current-unwind-protect-block*
+ sb!c::*eval-stack-top*
+
+ ;; Interrupt Handling
+ sb!impl::*free-interrupt-context-index*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ ))
+
+(defparameter *static-functions*
+ '(length
+ sb!kernel:two-arg-+
+ sb!kernel:two-arg--
+ sb!kernel:two-arg-*
+ sb!kernel:two-arg-/
+ sb!kernel:two-arg-<
+ sb!kernel:two-arg->
+ sb!kernel:two-arg-=
+ ;; Probably need the following as they are defined in arith.lisp
+ ;; two-arg-<= two-arg->= two-arg-/=
+ eql
+ sb!kernel:%negate
+ sb!kernel:two-arg-and
+ sb!kernel:two-arg-ior
+ sb!kernel:two-arg-xor
+ sb!kernel:two-arg-gcd
+ sb!kernel:two-arg-lcm))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VM definition of predicate VOPs for the Alpha.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+\f
+;;;; The Branch VOP.
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination. Dest is the continuation we transfer control to.
+;;;
+(define-vop (branch)
+ (:info dest)
+ (:generator 5
+ (inst br zero-tn dest)))
+
+\f
+;;;; Conditional VOPs:
+
+(define-vop (if-eq)
+ (:args (x :scs (any-reg descriptor-reg zero null))
+ (y :scs (any-reg descriptor-reg zero null)))
+ (:conditional)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:translate eq)
+ (:generator 3
+ (inst cmpeq x y temp)
+ (if not-p
+ (inst beq temp target)
+ (inst bne temp target))))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains temporary printing utilities and similar noise.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+
+(in-package "SB!VM")
+
+
+
+(define-vop (print)
+ (:args (object :scs (descriptor-reg) :target a0))
+ (:results (result :scs (descriptor-reg)))
+ (:save-p t)
+ (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
+ cfunc)
+ (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:vop-var vop)
+ (:generator 0
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (move object a0)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst li (make-fixup "debug_print" :foreign) cfunc)
+ (inst li (make-fixup "call_into_c" :foreign) temp)
+ (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
+ (when cur-nfp
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
+ (move cfunc result))))
--- /dev/null
+;;; -*- Package: VM; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the Alpha VM definition of SAP operations.
+;;;
+;;; Written by William Lott.
+;;; Alpha conversion by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+\f
+;;;; Moves and coercions:
+
+;;; Move a tagged SAP to an untagged representation.
+;;;
+
+(define-vop (move-to-sap)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (sap-reg)))
+ (:note "system area pointer indirection")
+ (:generator 1
+ (loadq y x sap-pointer-slot other-pointer-type)))
+
+;;;
+(define-move-vop move-to-sap :move
+ (descriptor-reg) (sap-reg))
+
+
+;;; Move an untagged SAP to a tagged representation.
+;;;
+(define-vop (move-from-sap)
+ (:args (x :scs (sap-reg) :target sap))
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:results (y :scs (descriptor-reg)))
+ (:note "system area pointer allocation")
+ (:generator 20
+ (move x sap)
+ (with-fixed-allocation (y ndescr sap-type sap-size)
+ (storeq sap y sap-pointer-slot other-pointer-type))))
+;;;
+(define-move-vop move-from-sap :move
+ (sap-reg) (descriptor-reg))
+
+
+;;; Move untagged sap values.
+;;;
+(define-vop (sap-move)
+ (:args (x :target y
+ :scs (sap-reg)
+ :load-if (not (location= x y))))
+ (:results (y :scs (sap-reg)
+ :load-if (not (location= x y))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move x y)))
+;;;
+(define-move-vop sap-move :move
+ (sap-reg) (sap-reg))
+
+
+;;; Move untagged sap arguments/return-values.
+;;;
+(define-vop (move-sap-argument)
+ (:args (x :target y
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ (sap-reg
+ (move x y))
+ (sap-stack
+ (storeq x fp (tn-offset y))))))
+;;;
+(define-move-vop move-sap-argument :move-argument
+ (descriptor-reg sap-reg) (sap-reg))
+
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+;;;
+(define-move-vop move-argument :move-argument
+ (sap-reg) (descriptor-reg))
+
+
+\f
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+ (:args (sap :scs (sap-reg) :target int))
+ (:arg-types system-area-pointer)
+ (:results (int :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:translate sap-int)
+ (:policy :fast-safe)
+ (:generator 1
+ (move sap int)))
+
+(define-vop (int-sap)
+ (:args (int :scs (unsigned-reg) :target sap))
+ (:arg-types unsigned-num)
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate int-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (move int sap)))
+
+
+\f
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+ (:translate sap+)
+ (:args (ptr :scs (sap-reg))
+ (offset :scs (signed-reg immediate)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (sc-case offset
+ (signed-reg
+ (inst addq offset ptr res))
+ (immediate
+ (inst lda res (tn-value offset) ptr)))))
+
+(define-vop (pointer-)
+ (:translate sap-)
+ (:args (ptr1 :scs (sap-reg))
+ (ptr2 :scs (sap-reg)))
+ (:arg-types system-area-pointer system-area-pointer)
+ (:policy :fast-safe)
+ (:results (res :scs (signed-reg)))
+ (:result-types signed-num)
+ (:generator 1
+ (inst subq ptr1 ptr2 res)))
+
+\f
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(macrolet ((def-system-ref-and-set
+ (ref-name set-name sc type size &optional signed)
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C")))
+ `(progn
+ (define-vop (,ref-name)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ ,@(when (or (eq size :byte) (eq size :short))
+ `((:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ (:generator 5
+ (inst addq object offset sap)
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst ldq_u temp 0 sap)
+ (inst lda temp1 1 sap)
+ (inst extqh temp temp1 temp)
+ (inst sra temp 56 result))
+ '((inst ldq_u temp 0 sap)
+ (inst lda temp1 0 sap)
+ (inst extbl temp temp1 result))))
+ (:short
+ (if signed
+ '((inst ldq_u temp 0 sap)
+ (inst lda temp1 0 sap)
+ (inst extwl temp temp1 temp)
+ (inst sll temp 48 temp)
+ (inst sra temp 48 result))
+ '((inst ldq_u temp 0 sap)
+ (inst lda temp1 0 sap)
+ (inst extwl temp temp1 result))))
+ (:long
+ `((inst ldl result 0 sap)
+ ,@(unless signed
+ '((inst mskll result 4 result)))))
+ (:quad
+ '((inst ldq result 0 sap)))
+ (:single
+ '((inst lds result 0 sap)))
+ (:double
+ '((inst ldt result 0 sap))))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16))))
+ ,@(when (or (eq size :byte) (eq size :short))
+ `((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(ecase size
+ (:byte
+ (if signed
+ '((inst ldq_u temp offset object)
+ (inst lda temp1 (1+ offset) object)
+ (inst extqh temp temp1 temp)
+ (inst sra temp 56 result))
+ '((inst ldq_u temp offset object)
+ (inst lda temp1 offset object)
+ (inst extbl temp temp1 result))))
+ (:short
+ (if signed
+ '((inst ldq_u temp offset object)
+ (inst lda temp1 offset object)
+ (inst extwl temp temp1 temp)
+ (inst sll temp 48 temp)
+ (inst sra temp 48 result))
+ '((inst ldq_u temp offset object)
+ (inst lda temp1 offset object)
+ (inst extwl temp temp1 result))))
+ (:long
+ `((inst ldl result offset object)
+ ,@(unless signed
+ '((inst mskll result 4 result)))))
+ (:quad
+ '((inst ldq result offset object)))
+ (:single
+ '((inst lds result offset object)))
+ (:double
+ '((inst ldt result (+ offset word-bytes) object))))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg) :target sap)
+ (offset :scs (signed-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer signed-num ,type)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:temporary (:scs (sap-reg) :from (:argument 0)) sap)
+ ,@(when (or (eq size :byte) (eq size :short))
+ `((:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:temporary (:sc non-descriptor-reg) temp2)))
+ (:generator 5
+ (inst addq object offset sap)
+ ,@(ecase size
+ (:byte
+ '((inst lda temp 0 sap)
+ (inst ldq_u temp1 0 sap)
+ (inst insbl value temp temp2)
+ (inst mskbl temp1 temp temp1)
+ (inst bis temp1 temp2 temp1)
+ (inst stq_u temp1 0 sap)
+ (inst move value result)))
+ (:short
+ '((inst lda temp 0 sap)
+ (inst ldq_u temp1 0 sap)
+ (inst mskwl temp1 temp temp1)
+ (inst inswl value temp temp2)
+ (inst bis temp1 temp2 temp)
+ (inst stq_u temp 0 sap)
+ (inst move value result)))
+ (:long
+ '((inst stl value 0 sap)
+ (move value result)))
+ (:quad
+ '((inst stq value 0 sap)
+ (move value result)))
+ (:single
+ '((unless (location= result value)
+ (inst fmove value result))
+ (inst sts value 0 sap)))
+ (:double
+ '((unless (location= result value)
+ (inst fmove value result))
+ (inst stt value 0 sap))))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (object :scs (sap-reg))
+ (value :scs (,sc) :target result))
+ (:arg-types system-area-pointer
+ (:constant ,(if (eq size :double)
+ ;; We need to be able to add 4.
+ `(integer ,(- (ash 1 16))
+ ,(- (ash 1 16) 5))
+ '(signed-byte 16)))
+ ,type)
+ ,@(when (or (eq size :byte) (eq size :short))
+ `((:temporary (:sc non-descriptor-reg) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:temporary (:sc non-descriptor-reg) temp2)))
+ (:info offset)
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(ecase size
+ (:byte
+ '((inst lda temp offset object)
+ (inst ldq_u temp1 offset object)
+ (inst insbl value temp temp2)
+ (inst mskbl temp1 temp temp1)
+ (inst bis temp1 temp2 temp1)
+ (inst stq_u temp1 offset object)
+ (inst move value result)))
+ (:short
+ '((inst lda temp offset object)
+ (inst ldq_u temp1 offset object)
+ (inst mskwl temp1 temp temp1)
+ (inst inswl value temp temp2)
+ (inst bis temp1 temp2 temp)
+ (inst stq_u temp offset object)
+ (inst move value result)))
+ (:long
+ '((inst stl value offset object)
+ (move value result)))
+ (:quad
+ '((inst stq value offset object)
+ (move value result)))
+ (:single
+ '((unless (location= result value)
+ (inst fmove value result))
+ (inst sts value offset object)))
+ (:double
+ '((unless (location= result value)
+ (inst fmove value result))
+ (inst stt value offset object))))))))))
+ (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+ unsigned-reg positive-fixnum :byte nil)
+ (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+ signed-reg tagged-num :byte t)
+ (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+ unsigned-reg positive-fixnum :short nil)
+ (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+ signed-reg tagged-num :short t)
+ (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+ unsigned-reg unsigned-num :long nil)
+ (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+ signed-reg signed-num :long t)
+ (def-system-ref-and-set sap-ref-64 %set-sap-ref-64
+ unsigned-reg unsigned-num :quad nil)
+ (def-system-ref-and-set signed-sap-ref-64 %set-signed-sap-ref-64
+ signed-reg signed-num :quad t)
+ (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+ sap-reg system-area-pointer :quad)
+ (def-system-ref-and-set sap-ref-single %set-sap-ref-single
+ single-reg single-float :single)
+ (def-system-ref-and-set sap-ref-double %set-sap-ref-double
+ double-reg double-float :double))
+
+\f
+;;; Noise to convert normal lisp data objects into SAPs.
+
+(define-vop (vector-sap)
+ (:translate vector-sap)
+ (:policy :fast-safe)
+ (:args (vector :scs (descriptor-reg)))
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst lda sap
+ (- (* vector-data-offset word-bytes) other-pointer-type)
+ vector)))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains temporary printing utilities and similar noise.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+
+(in-package "SB!VM")
+
+
+
+(define-vop (print)
+ (:args (object :scs (descriptor-reg) :target a0))
+ (:results (result :scs (descriptor-reg)))
+ (:save-p t)
+ (:temporary (:sc any-reg :offset cfunc-offset :target result :to (:result 0))
+ cfunc)
+ (:temporary (:sc descriptor-reg :offset nl0-offset :from (:argument 0)) a0)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:vop-var vop)
+ (:generator 0
+ (let ((cur-nfp (current-nfp-tn vop)))
+ (move object a0)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst li (make-fixup "debug_print" :foreign) cfunc)
+ (inst li (make-fixup "call_into_c" :foreign) temp)
+ (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
+ (when cur-nfp
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
+ (move cfunc result))))
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the VOPs and macro magic necessary to call static
+;;; functions.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+
+
+(define-vop (static-function-template)
+ (:save-p t)
+ (:policy :safe)
+ (:variant-vars symbol)
+ (:vop-var vop)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg)) move-temp)
+ (:temporary (:sc descriptor-reg :offset lra-offset) lra)
+ (:temporary (:sc interior-reg :offset lip-offset) entry-point)
+ (:temporary (:sc any-reg :offset nargs-offset) nargs)
+ (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+
+(defun static-function-template-name (num-args num-results)
+ (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+ num-args num-results)))
+
+
+(defun moves (src dst)
+ (collect ((moves))
+ (do ((dst dst (cdr dst))
+ (src src (cdr src)))
+ ((or (null dst) (null src)))
+ (moves `(move ,(car src) ,(car dst))))
+ (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+ (assert (and (<= num-args register-arg-count)
+ (<= num-results register-arg-count))
+ (num-args num-results)
+ "Either too many args (~D) or too many results (~D). Max = ~D"
+ num-args num-results register-arg-count)
+ (let ((num-temps (max num-args num-results)))
+ (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+ (dotimes (i num-results)
+ (let ((result-name (intern (format nil "RESULT-~D" i))))
+ (result-names result-name)
+ (results `(,result-name :scs (any-reg descriptor-reg)))))
+ (dotimes (i num-temps)
+ (let ((temp-name (intern (format nil "TEMP-~D" i))))
+ (temp-names temp-name)
+ (temps `(:temporary (:sc descriptor-reg
+ :offset ,(nth i *register-arg-offsets*)
+ ,@(when (< i num-args)
+ `(:from (:argument ,i)))
+ ,@(when (< i num-results)
+ `(:to (:result ,i)
+ :target ,(nth i (result-names)))))
+ ,temp-name))))
+ (dotimes (i num-args)
+ (let ((arg-name (intern (format nil "ARG-~D" i))))
+ (arg-names arg-name)
+ (args `(,arg-name
+ :scs (any-reg descriptor-reg null zero)
+ :target ,(nth i (temp-names))))))
+ `(define-vop (,(static-function-template-name num-args num-results)
+ static-function-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ (let ((lra-label (gen-label))
+ (cur-nfp (current-nfp-tn vop)))
+ ,@(moves (arg-names) (temp-names))
+ (inst li (fixnumize ,num-args) nargs)
+ (inst ldl entry-point (static-function-offset symbol) null-tn)
+ (when cur-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (inst move cfp-tn ocfp)
+ (inst compute-lra-from-code lra code-tn lra-label temp)
+ (note-this-location vop :call-site)
+ (inst move csp-tn cfp-tn)
+ (inst jsr zero-tn entry-point)
+ (emit-return-pc lra-label)
+ ,(collect ((bindings) (links))
+ (do ((temp (temp-names) (cdr temp))
+ (name 'values (gensym))
+ (prev nil name)
+ (i 0 (1+ i)))
+ ((= i num-results))
+ (bindings `(,name
+ (make-tn-ref ,(car temp) nil)))
+ (when prev
+ (links `(setf (tn-ref-across ,prev) ,name))))
+ `(let ,(bindings)
+ ,@(links)
+ (default-unknown-values vop
+ ,(if (zerop num-results) nil 'values)
+ ,num-results move-temp temp lra-label)))
+ (when cur-nfp
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
+ ,@(moves (temp-names) (result-names))))))))
+
+
+) ; eval-when (compile load eval)
+
+
+(expand
+ (collect ((templates (list 'progn)))
+ (dotimes (i register-arg-count)
+ (templates (static-function-template-vop i 1)))
+ (templates)))
+
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+ policy cost arg-types result-types)
+ `(define-vop (,name
+ ,(static-function-template-name (length args)
+ (length results)))
+ (:variant ',name)
+ (:note ,(format nil "static-function ~@(~S~)" name))
+ ,@(when translate
+ `((:translate ,translate)))
+ ,@(when policy
+ `((:policy ,policy)))
+ ,@(when cost
+ `((:generator-cost ,cost)))
+ ,@(when arg-types
+ `((:arg-types ,@arg-types)))
+ ,@(when result-types
+ `((:result-types ,@result-types)))))
--- /dev/null
+;;; -*- Package: ALPHA; Log: C.Log -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; Linkage information for standard static functions, and random vops.
+;;;
+;;; Written by William Lott.
+;;; Converted by Sean Hallgren.
+;;;
+(in-package "SB!VM")
+
+
+
+\f
+;;;; Length
+
+(define-vop (length/list)
+ (:translate length)
+ (:args (object :scs (descriptor-reg) :target ptr))
+ (:arg-types list)
+ (:temporary (:scs (descriptor-reg) :from (:argument 0)) ptr)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (any-reg) :type fixnum :to (:result 0) :target result)
+ count)
+ (:results (result :scs (any-reg descriptor-reg)))
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 50
+ (move object ptr)
+ (move zero-tn count)
+
+ LOOP
+
+ (inst cmpeq ptr null-tn temp)
+ (inst bne temp done)
+
+ (inst and ptr lowtag-mask temp)
+ (inst xor temp list-pointer-type temp)
+ (inst bne temp not-list)
+
+ (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (inst addq count (fixnumize 1) count)
+ (inst br zero-tn loop)
+
+ NOT-LIST
+ (cerror-call vop done object-not-list-error ptr)
+
+ DONE
+ (move count result)))
+
+
+(define-static-function length (object) :translate length)
+
+
+
--- /dev/null
+;;;; Alpha VM definitions of various system hacking operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+\f
+;;;; Type frobbing VOPs
+
+(define-vop (get-lowtag)
+ (:translate get-lowtag)
+ (:policy :fast-safe)
+ (:args (object :scs (any-reg descriptor-reg)))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (inst and object lowtag-mask result)))
+
+(define-vop (get-type)
+ (:translate get-type)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ ;; Pick off objects with headers.
+ (inst and object lowtag-mask result)
+ (inst cmpeq result other-pointer-type ndescr)
+ (inst bne ndescr other-ptr)
+ (inst cmpeq result function-pointer-type ndescr)
+ (inst bne ndescr function-ptr)
+
+ ;; Pick off structure and list pointers.
+ (inst blbs object done)
+
+ ;; Pick off fixnums.
+ (inst and object 3 result)
+ (inst beq result done)
+
+ ;; Must be an other immediate.
+ (inst and object type-mask result)
+ (inst br zero-tn done)
+
+ FUNCTION-PTR
+ (load-type result object (- function-pointer-type))
+ (inst br zero-tn done)
+
+ OTHER-PTR
+ (load-type result object (- other-pointer-type))
+
+ DONE))
+
+(define-vop (function-subtype)
+ (:translate function-subtype)
+ (:policy :fast-safe)
+ (:args (function :scs (descriptor-reg)))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (load-type result function (- function-pointer-type))))
+
+(define-vop (set-function-subtype)
+ (:translate (setf function-subtype))
+ (:policy :fast-safe)
+ (:args (type :scs (unsigned-reg) :target result)
+ (function :scs (descriptor-reg)))
+ (:arg-types positive-fixnum *)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (inst ldl temp (- function-pointer-type) function)
+ (inst and temp #xff temp)
+ (inst bis type temp temp)
+ (inst stl temp (- function-pointer-type) function)
+ (move type result)))
+
+
+(define-vop (get-header-data)
+ (:translate get-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 other-pointer-type)
+ (inst srl res type-bits res)))
+
+(define-vop (get-closure-length)
+ (:translate get-closure-length)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 function-pointer-type)
+ (inst srl res type-bits res)))
+
+(define-vop (set-header-data)
+ (:translate set-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg) :target res)
+ (data :scs (any-reg immediate zero)))
+ (:arg-types * positive-fixnum)
+ (:results (res :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) t1 t2)
+ (:generator 6
+ (loadw t1 x 0 other-pointer-type)
+ (inst and t1 type-mask t1)
+ (sc-case data
+ (any-reg
+ (inst sll data (- type-bits 2) t2)
+ (inst bis t1 t2 t1))
+ (immediate
+ (let ((c (ash (tn-value data) type-bits)))
+ (cond ((<= 0 c (1- (ash 1 8)))
+ (inst bis t1 c t1))
+ (t
+ (inst li c t2)
+ (inst bis t1 t2 t1)))))
+ (zero))
+ (storew t1 x 0 other-pointer-type)
+ (move x res)))
+
+(define-vop (make-fixnum)
+ (:args (ptr :scs (any-reg descriptor-reg)))
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ ;;
+ ;; Some code (the hash table code) depends on this returning a
+ ;; positive number so make sure it does.
+ (inst sll ptr 35 res)
+ (inst srl res 33 res)))
+
+(define-vop (make-other-immediate-type)
+ (:args (val :scs (any-reg descriptor-reg))
+ (type :scs (any-reg descriptor-reg immediate)
+ :target temp))
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 2
+ (sc-case type
+ ((immediate)
+ (inst sll val type-bits temp)
+ (inst bis temp (tn-value type) res))
+ (t
+ (inst sra type 2 temp)
+ (inst sll val (- type-bits 2) res)
+ (inst bis res temp res)))))
+
+\f
+;;;; Allocation
+
+(define-vop (dynamic-space-free-pointer)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate dynamic-space-free-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (move alloc-tn int)))
+
+(define-vop (binding-stack-pointer-sap)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate binding-stack-pointer-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (move bsp-tn int)))
+
+(define-vop (control-stack-pointer-sap)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate control-stack-pointer-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (move csp-tn int)))
+
+\f
+;;;; Code object frobbing.
+
+(define-vop (code-instructions)
+ (:translate code-instructions)
+ (:policy :fast-safe)
+ (:args (code :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 10
+ (loadw ndescr code 0 other-pointer-type)
+ (inst srl ndescr type-bits ndescr)
+ (inst sll ndescr word-shift ndescr)
+ (inst subq ndescr other-pointer-type ndescr)
+ (inst addq code ndescr sap)))
+
+(define-vop (compute-function)
+ (:args (code :scs (descriptor-reg))
+ (offset :scs (signed-reg unsigned-reg)))
+ (:arg-types * positive-fixnum)
+ (:results (func :scs (descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:generator 10
+ (loadw ndescr code 0 other-pointer-type)
+ (inst srl ndescr type-bits ndescr)
+ (inst sll ndescr word-shift ndescr)
+ (inst addq ndescr offset ndescr)
+ (inst subq ndescr (- other-pointer-type function-pointer-type) ndescr)
+ (inst addq code ndescr func)))
+
+\f
+;;;; Other random VOPs.
+
+
+(defknown sb!unix::do-pending-interrupt () (values))
+(define-vop (sb!unix::do-pending-interrupt)
+ (:policy :fast-safe)
+ (:translate sb!unix::do-pending-interrupt)
+ (:generator 1
+ (inst gentrap pending-interrupt-trap)))
+
+
+(define-vop (halt)
+ (:generator 1
+ (inst gentrap halt-trap)))
+
+\f
+;;;; Dynamic vop count collection support
+
+(define-vop (count-me)
+ (:args (count-vector :scs (descriptor-reg)))
+ (:info index)
+ (:temporary (:scs (non-descriptor-reg)) count)
+ (:generator 1
+ (let ((offset
+ (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
+ (inst ldl count offset count-vector)
+ (inst addq count 1 count)
+ (inst stl count offset count-vector))))
--- /dev/null
+;;; dunno quite what needs to be in here
+
+(in-package "SB!VM")
+
+;;; foo
+
--- /dev/null
+;;;; type testing and checking VOPs for the Alpha VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+
+\f
+;;;; Test generation utilities.
+
+(eval-when (:compile-toplevel :execute)
+
+(defparameter immediate-types
+ (list unbound-marker-type base-char-type))
+
+(defparameter function-header-types
+ (list funcallable-instance-header-type
+ byte-code-function-type byte-code-closure-type
+ function-header-type closure-function-header-type
+ closure-header-type))
+
+(defun canonicalize-headers (headers)
+ (collect ((results))
+ (let ((start nil)
+ (prev nil)
+ (delta (- other-immediate-1-type other-immediate-0-type)))
+ (flet ((emit-test ()
+ (results (if (= start prev)
+ start
+ (cons start prev)))))
+ (dolist (header (sort headers #'<))
+ (cond ((null start)
+ (setf start header)
+ (setf prev header))
+ ((= header (+ prev delta))
+ (setf prev header))
+ (t
+ (emit-test)
+ (setf start header)
+ (setf prev header))))
+ (emit-test)))
+ (results)))
+
+) ; EVAL-WHEN
+
+(macrolet ((test-type (value temp target not-p &rest type-codes)
+ ;; Determine what interesting combinations we need to test for.
+ (let* ((type-codes (mapcar #'eval type-codes))
+ (fixnump (and (member even-fixnum-type type-codes)
+ (member odd-fixnum-type type-codes)
+ t))
+ (lowtags (remove lowtag-limit type-codes :test #'<))
+ (extended (remove lowtag-limit type-codes :test #'>))
+ (immediates (intersection extended immediate-types :test #'eql))
+ (headers (set-difference extended immediate-types :test #'eql))
+ (function-p (if (intersection headers function-header-types)
+ (if (subsetp headers function-header-types)
+ t
+ (error "Can't test for mix of function subtypes ~
+ and normal header types."))
+ nil)))
+ (unless type-codes
+ (error "Must supply at least on type for test-type."))
+ (cond
+ (fixnump
+ (when (remove-if #'(lambda (x)
+ (or (= x even-fixnum-type)
+ (= x odd-fixnum-type)))
+ lowtags)
+ (error "Can't mix fixnum testing with other lowtags."))
+ (when function-p
+ (error "Can't mix fixnum testing with function subtype testing."))
+ (when immediates
+ (error "Can't mix fixnum testing with other immediates."))
+ (if headers
+ `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
+ ',(canonicalize-headers headers))
+ `(%test-fixnum ,value ,temp ,target ,not-p)))
+ (immediates
+ (when headers
+ (error "Can't mix testing of immediates with testing of headers."))
+ (when lowtags
+ (error "Can't mix testing of immediates with testing of lowtags."))
+ (when (cdr immediates)
+ (error "Can't test multiple immediates at the same time."))
+ `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
+ (lowtags
+ (when (cdr lowtags)
+ (error "Can't test multiple lowtags at the same time."))
+ (if headers
+ `(%test-lowtag-and-headers
+ ,value ,temp ,target ,not-p ,(car lowtags)
+ ,function-p ',(canonicalize-headers headers))
+ `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
+ (headers
+ `(%test-headers ,value ,temp ,target ,not-p ,function-p
+ ',(canonicalize-headers headers)))
+ (t
+ (error "Nothing to test?"))))))
+
+(defun %test-fixnum (value temp target not-p)
+ (assemble ()
+ (inst and value 3 temp)
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))))
+
+(defun %test-fixnum-and-headers (value temp target not-p headers)
+ (let ((drop-through (gen-label)))
+ (assemble ()
+ (inst and value 3 temp)
+ (inst beq temp (if not-p drop-through target)))
+ (%test-headers value temp target not-p nil headers drop-through)))
+
+(defun %test-immediate (value temp target not-p immediate)
+ (assemble ()
+ (inst and value 255 temp)
+ (inst xor temp immediate temp)
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))))
+
+(defun %test-lowtag (value temp target not-p lowtag)
+ (assemble ()
+ (inst and value lowtag-mask temp)
+ (inst xor temp lowtag temp)
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))))
+
+(defun %test-lowtag-and-headers (value temp target not-p lowtag
+ function-p headers)
+ (let ((drop-through (gen-label)))
+ (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+ (%test-headers value temp target not-p function-p headers drop-through)))
+
+(defun %test-headers (value temp target not-p function-p headers
+ &optional (drop-through (gen-label)))
+ (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (multiple-value-bind
+ (when-true when-false)
+ ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
+ ;; we know it's true and when we know it's false respectively.
+ (if not-p
+ (values drop-through target)
+ (values target drop-through))
+ (assemble ()
+ (%test-lowtag value temp when-false t lowtag)
+ (load-type temp value (- lowtag))
+ (let ((delta 0))
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst subq temp (- header delta) temp)
+ (setf delta header)
+ (if last
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))
+ (inst beq temp when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-type)
+ (inst subq temp (- start delta) temp)
+ (setf delta start)
+ (inst blt temp when-false))
+ (inst subq temp (- end delta) temp)
+ (setf delta end)
+ (if last
+ (if not-p
+ (inst bgt temp target)
+ (inst ble temp target))
+ (inst ble temp when-true))))))))
+ (emit-label drop-through)))))
+
+
+\f
+;;;; Type checking and testing:
+
+(define-vop (check-type)
+ (:args (value :target result :scs (any-reg descriptor-reg)))
+ (:results (result :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(define-vop (type-predicate)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe))
+
+
+(eval-when (:compile-toplevel :execute)
+
+
+(defun cost-to-test-types (type-codes)
+ (+ (* 2 (length type-codes))
+ (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+)
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+ &rest type-codes)
+ (let ((cost #+sb-xc-host (cost-to-test-types (mapcar #'eval type-codes))
+ #-sb-xc-host 10))
+ `(progn
+ ,@(when pred-name
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value temp target not-p ,@type-codes)))))
+ ,@(when check-name
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value temp err-lab t ,@type-codes)
+ (move value result))))))
+ ,@(when ptype
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+
+(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+ even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+ object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+ list-pointer-type)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+ instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+ object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+ object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex
+ object-not-complex-error complex-type
+ complex-single-float-type complex-double-float-type)
+
+(def-type-vops complex-rational-p check-complex-rational nil
+ object-not-complex-rational-error complex-type)
+
+(def-type-vops complex-float-p check-complex-float nil
+ object-not-complex-float-error
+ complex-single-float-type complex-double-float-type)
+
+(def-type-vops complex-single-float-p check-complex-single-float
+ complex-single-float object-not-complex-single-float-error
+ complex-single-float-type)
+
+(def-type-vops complex-double-float-p check-complex-double-float
+ complex-double-float object-not-complex-double-float-error
+ complex-double-float-type)
+
+(def-type-vops single-float-p check-single-float single-float
+ object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+ object-not-double-float-error double-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+ object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+ object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+ object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+ check-simple-array-unsigned-byte-2
+ simple-array-unsigned-byte-2
+ object-not-simple-array-unsigned-byte-2-error
+ simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+ check-simple-array-unsigned-byte-4
+ simple-array-unsigned-byte-4
+ object-not-simple-array-unsigned-byte-4-error
+ simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+ check-simple-array-unsigned-byte-8
+ simple-array-unsigned-byte-8
+ object-not-simple-array-unsigned-byte-8-error
+ simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+ check-simple-array-unsigned-byte-16
+ simple-array-unsigned-byte-16
+ object-not-simple-array-unsigned-byte-16-error
+ simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+ check-simple-array-unsigned-byte-32
+ simple-array-unsigned-byte-32
+ object-not-simple-array-unsigned-byte-32-error
+ simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-signed-byte-8-p
+ check-simple-array-signed-byte-8
+ simple-array-signed-byte-8
+ object-not-simple-array-signed-byte-8-error
+ simple-array-signed-byte-8-type)
+
+(def-type-vops simple-array-signed-byte-16-p
+ check-simple-array-signed-byte-16
+ simple-array-signed-byte-16
+ object-not-simple-array-signed-byte-16-error
+ simple-array-signed-byte-16-type)
+
+(def-type-vops simple-array-signed-byte-30-p
+ check-simple-array-signed-byte-30
+ simple-array-signed-byte-30
+ object-not-simple-array-signed-byte-30-error
+ simple-array-signed-byte-30-type)
+
+(def-type-vops simple-array-signed-byte-32-p
+ check-simple-array-signed-byte-32
+ simple-array-signed-byte-32
+ object-not-simple-array-signed-byte-32-error
+ simple-array-signed-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+ simple-array-single-float object-not-simple-array-single-float-error
+ simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+ simple-array-double-float object-not-simple-array-double-float-error
+ simple-array-double-float-type)
+
+(def-type-vops simple-array-complex-single-float-p
+ check-simple-array-complex-single-float
+ simple-array-complex-single-float
+ object-not-simple-array-complex-single-float-error
+ simple-array-complex-single-float-type)
+
+(def-type-vops simple-array-complex-double-float-p
+ check-simple-array-complex-double-float
+ simple-array-complex-double-float
+ object-not-simple-array-complex-double-float-error
+ simple-array-complex-double-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+ object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+ system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+ object-not-weak-pointer-error weak-pointer-type)
+
+
+;;; XXX
+#|
+(def-type-vops scavenger-hook-p nil nil nil
+ #-gengc 0 #+gengc scavenger-hook-type)
+|#
+
+(def-type-vops code-component-p nil nil nil
+ code-header-type)
+
+(def-type-vops lra-p nil nil nil
+ #-gengc return-pc-header-type #+gengc 0)
+
+(def-type-vops fdefn-p nil nil nil
+ fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+ funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+ simple-array-type complex-string-type complex-bit-vector-type
+ complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+ object-not-function-or-symbol-error
+ function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+ simple-string-type complex-string-type)
+
+;;; XXX surely just sticking this in here is not all that's required
+;;; to create the vop? But I can't find out any other info
+(def-type-vops complex-vector-p check-complex-vector nil
+ object-not-complex-vector-error complex-vector-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+ simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+ simple-string-type simple-bit-vector-type simple-vector-type
+ simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+ simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+ simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type
+ complex-string-type complex-bit-vector-type complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+ simple-array-type simple-string-type simple-bit-vector-type
+ simple-vector-type simple-array-unsigned-byte-2-type
+ simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+ simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+ simple-array-type simple-string-type simple-bit-vector-type
+ simple-vector-type simple-array-unsigned-byte-2-type
+ simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+ simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type
+ complex-string-type complex-bit-vector-type complex-vector-type
+ complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+ even-fixnum-type odd-fixnum-type bignum-type ratio-type
+ single-float-type double-float-type complex-type
+ complex-single-float-type complex-double-float-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+ even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+ even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+ single-float-type double-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+ even-fixnum-type odd-fixnum-type ratio-type bignum-type
+ single-float-type double-float-type)
+
+\f
+;;;; Other integer ranges.
+
+;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+
+(defun signed-byte-32-test (value temp temp1 not-p target not-target)
+ (multiple-value-bind
+ (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (assemble ()
+ (inst and value 3 temp)
+ (inst beq temp yep)
+ (inst and value lowtag-mask temp)
+ (inst xor temp other-pointer-type temp)
+ (inst bne temp nope)
+ (loadw temp value 0 other-pointer-type)
+ (inst li (+ (ash 1 type-bits) bignum-type) temp1)
+ (inst xor temp temp1 temp)
+ (if not-p
+ (inst bne temp target)
+ (inst beq temp target))))
+ (values))
+
+(define-vop (signed-byte-32-p type-predicate)
+ (:translate signed-byte-32-p)
+ (:temporary (:scs (non-descriptor-reg)) temp1)
+ (:generator 45
+ (signed-byte-32-test value temp temp1 not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+ (:temporary (:scs (non-descriptor-reg)) temp1)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-signed-byte-32-error
+ value)))
+ (signed-byte-32-test value temp temp1 t loose okay))
+ OKAY
+ (move value result)))
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+(defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
+ (multiple-value-bind (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (assemble ()
+ ;; Is it a fixnum?
+ (inst and value 3 temp1)
+ (inst move value temp)
+ (inst beq temp1 fixnum)
+
+ ;; If not, is it an other pointer?
+ (inst and value lowtag-mask temp)
+ (inst xor temp other-pointer-type temp)
+ (inst bne temp nope)
+ ;; Get the header.
+ (loadw temp value 0 other-pointer-type)
+ ;; Is it one?
+ (inst li (+ (ash 1 type-bits) bignum-type) temp1)
+ (inst xor temp temp1 temp)
+ (inst beq temp single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst li (logxor (+ (ash 1 type-bits) bignum-type)
+ (+ (ash 2 type-bits) bignum-type))
+ temp1)
+ (inst xor temp temp1 temp)
+ (inst bne temp nope)
+ ;; Get the second digit.
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst beq temp yep)
+ (inst br zero-tn nope)
+
+ SINGLE-WORD
+ ;; Get the single digit.
+ (loadw temp value bignum-digits-offset other-pointer-type)
+
+ ;; positive implies (unsigned-byte 32).
+ FIXNUM
+ (if not-p
+ (inst blt temp target)
+ (inst bge temp target))))
+ (values))
+
+(define-vop (unsigned-byte-32-p type-predicate)
+ (:translate unsigned-byte-32-p)
+ (:temporary (:scs (non-descriptor-reg)) temp1)
+ (:generator 45
+ (unsigned-byte-32-test value temp temp1 not-p target not-target)
+ NOT-TARGET))
+
+(define-vop (check-unsigned-byte-32 check-type)
+ (:temporary (:scs (non-descriptor-reg)) temp1)
+ (:generator 45
+ (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
+ value)))
+ (unsigned-byte-32-test value temp temp1 t loose okay))
+ OKAY
+ (move value result)))
+
+
+\f
+;;;; List/symbol types:
+;;;
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+ (:translate symbolp)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 12
+ (inst cmpeq value null-tn temp)
+ (inst bne temp (if not-p drop-thru target))
+ (test-type value temp target not-p symbol-header-type)
+ DROP-THRU))
+
+(define-vop (check-symbol check-type)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 12
+ (inst cmpeq value null-tn temp)
+ (inst bne temp drop-thru)
+ (let ((error (generate-error-code vop object-not-symbol-error value)))
+ (test-type value temp error t symbol-header-type))
+ DROP-THRU
+ (move value result)))
+
+(define-vop (consp type-predicate)
+ (:translate consp)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 8
+ (inst cmpeq value null-tn temp)
+ (inst bne temp (if not-p target drop-thru))
+ (test-type value temp target not-p list-pointer-type)
+ DROP-THRU))
+
+(define-vop (check-cons check-type)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:generator 8
+ (let ((error (generate-error-code vop object-not-cons-error value)))
+ (inst cmpeq value null-tn temp)
+ (inst bne temp error)
+ (test-type value temp error t list-pointer-type))
+ (move value result)))
+
+) ; MACROLET
\ No newline at end of file
--- /dev/null
+;;; -*- Package: ALPHA -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;;
+
+;;;
+;;; **********************************************************************
+;;;
+;;; This file contains the implementation of unknown-values VOPs.
+;;;
+;;; Written by Rob MacLachlan
+;;;
+;;; Converted to the Alpha by Sean Hallgren.
+;;;
+
+(in-package "SB!VM")
+
+
+(define-vop (reset-stack-pointer)
+ (:args (ptr :scs (any-reg)))
+ (:generator 1
+ (move ptr csp-tn)))
+
+
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results. It is assumed that the Vals are wired to the standard
+;;; argument locations. Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random. We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+;;;
+(define-vop (push-values)
+ (:args
+ (vals :more t))
+ (:results
+ (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:info nvals)
+ (:temporary (:scs (descriptor-reg)) temp)
+ (:temporary (:scs (descriptor-reg)
+ :to (:result 0)
+ :target start)
+ start-temp)
+ (:generator 20
+ (move csp-tn start-temp)
+ (inst lda csp-tn (* nvals word-bytes) csp-tn)
+ (do ((val vals (tn-ref-across val))
+ (i 0 (1+ i)))
+ ((null val))
+ (let ((tn (tn-ref-tn val)))
+ (sc-case tn
+ (descriptor-reg
+ (storew tn start-temp i))
+ (control-stack
+ (load-stack-tn temp tn)
+ (storew temp start-temp i)))))
+ (move start-temp start)
+ (inst li (fixnumize nvals) count)))
+
+
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+;;;
+(define-vop (values-list)
+ (:args (arg :scs (descriptor-reg) :target list))
+ (:arg-types list)
+ (:policy :fast-safe)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:temporary (:scs (descriptor-reg) :type list :from (:argument 0)) list)
+ (:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 0
+ (move arg list)
+ (move csp-tn start)
+
+ LOOP
+ (inst cmpeq list null-tn temp)
+ (inst bne temp done)
+ (loadw temp list cons-car-slot list-pointer-type)
+ (loadw list list cons-cdr-slot list-pointer-type)
+ (inst lda csp-tn word-bytes csp-tn)
+ (storew temp csp-tn -1)
+ (inst and list lowtag-mask ndescr)
+ (inst xor ndescr list-pointer-type ndescr)
+ (inst beq ndescr loop)
+ (error-call vop bogus-argument-to-values-list-error list)
+
+ DONE
+ (inst subq csp-tn start count)))
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+(define-vop (%more-arg-values)
+ (:args (context :scs (descriptor-reg any-reg) :target src)
+ (skip :scs (any-reg zero immediate))
+ (num :scs (any-reg) :target count))
+ (:arg-types * positive-fixnum positive-fixnum)
+ (:temporary (:sc any-reg :from (:argument 0)) src)
+ (:temporary (:sc any-reg :from (:argument 2)) dst)
+ (:temporary (:sc descriptor-reg :from (:argument 1)) temp)
+ (:temporary (:sc non-descriptor-reg) temp1)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:generator 20
+ (sc-case skip
+ (zero
+ (move context src))
+ (immediate
+ (inst lda src (* (tn-value skip) word-bytes) context))
+ (any-reg
+ (inst addq context skip src)))
+ (move num count)
+ (inst move csp-tn start)
+ (inst beq num done)
+ (inst move csp-tn dst)
+ (inst addq csp-tn count csp-tn)
+ LOOP
+ (inst ldl temp 0 src)
+ (inst addq src 4 src)
+ (inst addq dst 4 dst)
+ (inst stl temp -4 dst)
+ (inst cmpeq dst csp-tn temp1)
+ (inst beq temp1 loop)
+ DONE))
--- /dev/null
+;;;; miscellaneous VM definition noise for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+
+\f
+;;;; Define the registers
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *register-names* (make-array 32 :initial-element nil)))
+
+(macrolet ((defreg (name offset)
+ (let ((offset-sym (symbolicate name "-OFFSET")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,offset-sym ,offset)
+ (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter ,name
+ (list ,@(mapcar #'(lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
+ ;; c.f. src/runtime/alpha-lispregs.h
+
+ ;; Ra
+ (defreg lip 0)
+ ;; Caller saved 0-7
+ (defreg a0 1)
+ (defreg a1 2)
+ (defreg a2 3)
+ (defreg a3 4)
+ (defreg a4 5)
+ (defreg a5 6)
+ (defreg l0 7)
+ (defreg nargs 8)
+ ;; Callee saved 0-6
+ (defreg csp 9)
+ (defreg cfp 10)
+ (defreg ocfp 11)
+ (defreg bsp 12)
+ (defreg lexenv 13)
+ (defreg code 14)
+ (defreg null 15)
+ ;; Arg 0-5
+ (defreg nl0 16)
+ (defreg nl1 17)
+ (defreg nl2 18)
+ (defreg nl3 19)
+ (defreg nl4 20)
+ (defreg nl5 21)
+ ;; Caller saved 8-11
+ (defreg alloc 22)
+ (defreg fdefn 23)
+ (defreg cfunc 24)
+ (defreg nfp 25)
+ ;; Ra
+ (defreg lra 26)
+ ;; Caller saved 12
+ (defreg l1 27)
+ ;; Assembler temp (at)
+ (defreg l2 28)
+ ;; Global pointer (gp)
+ (defreg gp 29)
+ ;; Stack pointer
+ (defreg nsp 30)
+ ;; Wired zero
+ (defreg zero 31)
+
+ (defregset non-descriptor-regs
+ nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
+
+ (defregset descriptor-regs
+ fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
+
+ (defregset *register-arg-offsets*
+ a0 a1 a2 a3 a4 a5)
+ (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5)))
+
+(define-storage-base registers :finite :size 32)
+(define-storage-base float-registers :finite :size 64)
+(define-storage-base control-stack :unbounded :size 8)
+(define-storage-base non-descriptor-stack :unbounded :size 0)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+
+;;;
+;;; Handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class.
+;;; FIXME: This macro is not needed in the runtime target.
+
+(defmacro define-storage-classes (&rest classes)
+ (do ((forms (list 'progn)
+ (let* ((class (car classes))
+ (sc-name (car class))
+ (constant-name (intern (concatenate 'simple-string
+ (string sc-name)
+ "-SC-NUMBER"))))
+ (list* `(define-storage-class ,sc-name ,index
+ ,@(cdr class))
+ `(defconstant ,constant-name ,index)
+ `(export ',constant-name)
+ forms)))
+ (index 0 (1+ index))
+ (classes classes (cdr classes)))
+ ((null classes)
+ (nreverse forms))))
+
+;;; see comment in ../x86/vm.lisp. The value of 7 was taken from
+;;; vm:catch-block-size in a cmucl that I happened to have around
+;;; and seems to be working so far -dan
+(defconstant sb!vm::kludge-nondeterministic-catch-block-size 7)
+
+
+(define-storage-classes
+
+ ;; Non-immediate contstants in the constant pool
+ (constant constant)
+
+ ;; ZERO and NULL are in registers.
+ (zero immediate-constant)
+ (null immediate-constant)
+ (fp-single-zero immediate-constant)
+ (fp-double-zero immediate-constant)
+
+ ;; Anything else that can be an immediate.
+ (immediate immediate-constant)
+
+
+ ;; **** The stacks.
+
+ ;; The control stack. (Scanned by GC)
+ (control-stack control-stack)
+
+ ;; The non-descriptor stacks.
+ (signed-stack non-descriptor-stack
+ :element-size 2 :alignment 2) ; (signed-byte 64)
+ (unsigned-stack non-descriptor-stack
+ :element-size 2 :alignment 2) ; (unsigned-byte 64)
+ (base-char-stack non-descriptor-stack) ; non-descriptor characters.
+ (sap-stack non-descriptor-stack
+ :element-size 2 :alignment 2) ; System area pointers.
+ (single-stack non-descriptor-stack) ; single-floats
+ (double-stack non-descriptor-stack
+ :element-size 2 :alignment 2) ; double floats.
+ (complex-single-stack non-descriptor-stack :element-size 2)
+ (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
+
+
+ ;; **** Things that can go in the integer registers.
+
+ ;; Immediate descriptor objects. Don't have to be seen by GC, but nothing
+ ;; bad will happen if they are. (fixnums, characters, header values, etc).
+ (any-reg
+ registers
+ :locations #.(append non-descriptor-regs descriptor-regs)
+; :locations #.non-descriptor-regs
+ :constant-scs (zero immediate)
+ :save-p t
+ :alternate-scs (control-stack))
+
+ ;; Pointer descriptor objects. Must be seen by GC.
+ (descriptor-reg registers
+ :locations #.descriptor-regs
+ :constant-scs (constant null immediate)
+ :save-p t
+ :alternate-scs (control-stack))
+
+ ;; Non-Descriptor characters
+ (base-char-reg registers
+ :locations #.non-descriptor-regs
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (base-char-stack))
+
+ ;; Non-Descriptor SAP's (arbitrary pointers into address space)
+ (sap-reg registers
+ :locations #.non-descriptor-regs
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (sap-stack))
+
+ ;; Non-Descriptor (signed or unsigned) numbers.
+ (signed-reg registers
+ :locations #.non-descriptor-regs
+ :constant-scs (zero immediate)
+ :save-p t
+ :alternate-scs (signed-stack))
+ (unsigned-reg registers
+ :locations #.non-descriptor-regs
+ :constant-scs (zero immediate)
+ :save-p t
+ :alternate-scs (unsigned-stack))
+
+ ;; Random objects that must not be seen by GC. Used only as temporaries.
+ (non-descriptor-reg registers
+ :locations #.non-descriptor-regs)
+
+ ;; Pointers to the interior of objects. Used only as an temporary.
+ (interior-reg registers
+ :locations (#.lip-offset))
+
+
+ ;; **** Things that can go in the floating point registers.
+
+ ;; Non-Descriptor single-floats.
+ (single-reg float-registers
+ :locations #.(loop for i from 4 to 30 collect i)
+ :constant-scs (fp-single-zero)
+ :save-p t
+ :alternate-scs (single-stack))
+
+ ;; Non-Descriptor double-floats.
+ (double-reg float-registers
+ :locations #.(loop for i from 4 to 30 collect i)
+ :constant-scs (fp-double-zero)
+ :save-p t
+ :alternate-scs (double-stack))
+
+ (complex-single-reg float-registers
+ :locations #.(loop for i from 4 to 28 by 2 collect i)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-single-stack))
+
+ (complex-double-reg float-registers
+ :locations #.(loop for i from 4 to 28 by 2 collect i)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-stack))
+
+ ;; A catch or unwind block.
+ (catch-block control-stack
+ :element-size sb!vm::kludge-nondeterministic-catch-block-size))
+
+\f
+;;;; Make some random tns for important registers.
+
+(macrolet ((defregtn (name sc)
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (tn-sym (symbolicate name "-TN")))
+ `(defparameter ,tn-sym
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc)
+ :offset ,offset-sym)))))
+
+ ;; These, we access by foo-TN only
+
+ (defregtn zero any-reg)
+ (defregtn null descriptor-reg)
+ (defregtn code descriptor-reg)
+ (defregtn alloc any-reg)
+ (defregtn bsp any-reg)
+ (defregtn csp any-reg)
+ (defregtn cfp any-reg)
+ (defregtn nsp any-reg)
+
+ ;; These alias regular locations, so we have to make sure we don't bypass
+ ;; the register allocator when using them.
+ (defregtn nargs any-reg)
+ (defregtn ocfp any-reg)
+ (defregtn lip interior-reg))
+
+;; And some floating point values.
+(defparameter fp-single-zero-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'single-reg)
+ :offset 31))
+(defparameter fp-double-zero-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset 31))
+
+\f
+;;; Immediate-Constant-SC -- Interface
+;;;
+;;; If value can be represented as an immediate constant, then return the
+;;; appropriate SC number, otherwise return NIL.
+;;;
+(!def-vm-support-routine immediate-constant-sc (value)
+ (typecase value
+ ((integer 0 0)
+ (sc-number-or-lose 'zero))
+ (null
+ (sc-number-or-lose 'null ))
+ ((or fixnum system-area-pointer character)
+ (sc-number-or-lose 'immediate ))
+ (symbol
+ (if (static-symbol-p value)
+ (sc-number-or-lose 'immediate )
+ nil))
+ (single-float
+ (if (eql value 0f0)
+ (sc-number-or-lose 'fp-single-zero )
+ nil))
+ (double-float
+ (if (eql value 0d0)
+ (sc-number-or-lose 'fp-double-zero )
+ nil))))
+\f
+;;;; Function Call Parameters
+
+;;; The SC numbers for register and stack arguments/return values.
+;;;
+(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
+(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
+(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Offsets of special stack frame locations
+(defconstant ocfp-save-offset 0)
+(defconstant lra-save-offset 1)
+(defconstant nfp-save-offset 2)
+
+;;; The number of arguments/return values passed in registers.
+;;;
+(defconstant register-arg-count 6)
+
+;;; Names to use for the argument registers.
+;;;
+
+
+); Eval-When (Compile Load Eval)
+
+
+;;; A list of TN's describing the register arguments.
+;;;
+(defparameter *register-arg-tns*
+ (mapcar #'(lambda (n)
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'descriptor-reg)
+ :offset n))
+ *register-arg-offsets*))
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+;;;
+(export 'single-value-return-byte-offset)
+(defconstant single-value-return-byte-offset 4)
+
+\f
+;;; LOCATION-PRINT-NAME -- Interface
+;;;
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location. It returns a thing that can be printed with PRINC.
+;;;
+(!def-vm-support-routine location-print-name (tn)
+; (declare (type tn tn))
+ (let ((sb (sb-name (sc-sb (tn-sc tn))))
+ (offset (tn-offset tn)))
+ (ecase sb
+ (registers (or (svref *register-names* offset)
+ (format nil "R~D" offset)))
+ (float-registers (format nil "F~D" offset))
+ (control-stack (format nil "CS~D" offset))
+ (non-descriptor-stack (format nil "NS~D" offset))
+ (constant (format nil "Const~D" offset))
+ (immediate-constant "Immed"))))
\f
;;;; main entries to object dumping
-;;; KLUDGE: This definition doesn't really belong in this file, but at
-;;; least it can be compiled without error here, and it's used here.
-;;; The definition requires the IGNORE-ERRORS macro, and in
-;;; sbcl-0.6.8.11 that's defined in early-target-error.lisp, and all
-;;; of the files which would otherwise be natural homes for this
-;;; definition (e.g. early-extensions.lisp or late-extensions.lisp)
-;;; are compiled before early-target-error.lisp. -- WHN 2000-11-07
-(defun circular-list-p (list)
- (and (listp list)
- (multiple-value-bind (res condition)
- (ignore-errors (list-length list))
- (if condition
- nil
- (null res)))))
-
;;; This function deals with dumping objects that are complex enough
;;; so that we want to cache them in the table, rather than repeatedly
;;; dumping them. If the object is in the EQ-TABLE, then we push it,
;; So if better list coalescing is needed, start here.
;; -- WHN 2000-11-07
(if (circular-list-p x)
- (progn
- (dump-list x file)
- (eq-save-object x file))
- (unless (equal-check-table x file)
- (dump-list x file)
- (equal-save-object x file))))
+ (progn
+ (dump-list x file)
+ (eq-save-object x file))
+ (unless (equal-check-table x file)
+ (dump-list x file)
+ (equal-save-object x file))))
(layout
(dump-layout x file)
(eq-save-object x file))
(cos %cos %cos-quick)
(tan %tan %tan-quick)))
(destructuring-bind (name prim prim-quick) stuff
+ (declare (ignorable prim-quick))
(deftransform name ((x) '(single-float) '* :eval-name t)
#!+x86 (cond ((csubtypep (continuation-type x)
(specifier-type '(single-float
(float pi x)
(float 0 x)))
-#!+(or sb-propagate-float-type sb-propagate-fun-type)
+;; #!+(or propagate-float-type propagate-fun-type)
(progn
;;; The number is of type REAL.
(logior (ash (ldb (byte 8 0) short) 8)
(ldb (byte 8 8) short))))
-;;; like SAP-REF-32, except that instead of a SAP we use a byte vector
-(defun byte-vector-ref-32 (byte-vector byte-index)
+;;; BYTE-VECTOR-REF-32 and friends. These are like SAP-REF-n, except
+;;; that instead of a SAP we use a byte vector
+(macrolet ((make-byte-vector-ref-n
+ (n)
+ (let* ((name (intern (format nil "BYTE-VECTOR-REF-~A" n)))
+ (number-octets (/ n 8))
+ (ash-list
+ (loop for i from 0 to (1- number-octets)
+ collect `(ash (aref byte-vector (+ byte-index ,i))
+ ,(* i 8))))
+ (setf-list
+ (loop for i from 0 to (1- number-octets)
+ append
+ `((aref byte-vector (+ byte-index ,i))
+ (ldb (byte 8 ,(* i 8)) new-value)))))
+ `(progn
+ (defun ,name (byte-vector byte-index)
(aver (= sb!vm:word-bits 32))
(aver (= sb!vm:byte-bits 8))
(ecase sb!c:*backend-byte-order*
(:little-endian
- (logior (ash (aref byte-vector (+ byte-index 0)) 0)
- (ash (aref byte-vector (+ byte-index 1)) 8)
- (ash (aref byte-vector (+ byte-index 2)) 16)
- (ash (aref byte-vector (+ byte-index 3)) 24)))
+ (logior ,@ash-list))
(:big-endian
(error "stub: no big-endian ports of SBCL (yet?)"))))
-(defun (setf byte-vector-ref-32) (new-value byte-vector byte-index)
+ (defun (setf ,name) (new-value byte-vector byte-index)
(aver (= sb!vm:word-bits 32))
(aver (= sb!vm:byte-bits 8))
(ecase sb!c:*backend-byte-order*
(:little-endian
- (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value)
- (aref byte-vector (+ byte-index 1)) (ldb (byte 8 8) new-value)
- (aref byte-vector (+ byte-index 2)) (ldb (byte 8 16) new-value)
- (aref byte-vector (+ byte-index 3)) (ldb (byte 8 24) new-value)))
+ (setf ,@setf-list))
(:big-endian
- (error "stub: no big-endian ports of SBCL (yet?)")))
- new-value)
+ (error "stub: no big-endian ports of SBCL (yet?)"))))))))
+ (make-byte-vector-ref-n 8)
+ (make-byte-vector-ref-n 16)
+ (make-byte-vector-ref-n 32))
(declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
(defun read-wordindexed (address index)
(setf (gethash name *cold-foreign-symbol-table*) value))))))
(values)))
+;;; FIXME: the relation between #'lookup-foreign-symbol and
+;;; #'lookup-maybe-prefix-foreign-symbol seems more than slightly
+;;; illdefined
+
(defun lookup-foreign-symbol (name)
- #!+x86
+ #!+(or alpha x86)
(let ((prefixes
#!+linux #(;; FIXME: How many of these are actually
;; needed? The first four are taken from rather
*cold-foreign-symbol-table*)
(format *error-output* "~&The prefix table is: ~S~%" prefixes)
(error "The foreign symbol ~S is undefined." name))))
- #!-x86 (error "non-x86 unsupported in SBCL (but see old CMU CL code)"))
+ #!-(or x86 alpha) (error "non-x86/alpha unsupported in SBCL (but see old CMU CL code)"))
(defvar *cold-assembler-routines*)
(gspace-byte-address (gspace-byte-address
(descriptor-gspace code-object))))
(ecase sb!c:*backend-fasl-file-implementation*
- ;; Classic CMU CL supported these, and I haven't gone out of my way
- ;; to break them, but I have no way of testing them.. -- WHN 19990817
- #|
- (#.sb!c:pmax-fasl-file-implementation
- (ecase kind
- (:jump
- (aver (zerop (ash value -28)))
- (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
- (ash value -2)))
- (:lui
- (setf (sap-ref-16 sap 0)
- (+ (ash value -16)
- (if (logbitp 15 value) 1 0))))
- (:addi
- (setf (sap-ref-16 sap 0)
- (ldb (byte 16 0) value)))))
- (#.sb!c:sparc-fasl-file-implementation
- (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+ ;; See CMUCL source for other formerly-supported architectures
+ ;; (and note that you have to rewrite them to use vector-ref unstead
+ ;; of sap-ref)
+ (:alpha
(ecase kind
- (:call
- (error "Can't deal with call fixups yet."))
- (:sethi
- (setf inst
- (dpb (ldb (byte 22 10) value)
- (byte 22 0)
- inst)))
- (:add
- (setf inst
- (dpb (ldb (byte 10 0) value)
- (byte 10 0)
- inst))))
- (setf (sap-ref-32 sap 0)
- (maybe-byte-swap inst))))
- ((#.sb!c:rt-fasl-file-implementation
- #.sb!c:rt-afpa-fasl-file-implementation)
- (ecase kind
- (:cal
- (setf (sap-ref-16 sap 2)
- (maybe-byte-swap-short
- (ldb (byte 16 0) value))))
- (:cau
- (let ((high (ldb (byte 16 16) value)))
- (setf (sap-ref-16 sap 2)
- (maybe-byte-swap-short
- (if (logbitp 15 value) (1+ high) high)))))
- (:ba
- (unless (zerop (ash value -24))
- (warn "#X~8,'0X out of range for branch-absolute." value))
- (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
+ (:jmp-hint
+ (assert (zerop (ldb (byte 2 0) value)))
+ #+nil ;; was commented out in cmucl source too. Don't know what
+ ;; it does -dan 2001.05.03
(setf (sap-ref-16 sap 0)
- (maybe-byte-swap-short
- (dpb (ldb (byte 8 16) value)
- (byte 8 0)
- inst))))
- (setf (sap-ref-16 sap 2)
- (maybe-byte-swap-short (ldb (byte 16 0) value))))))
- |#
+ (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
+ (:bits-63-48
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
+ (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
+ (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (ldb (byte 8 48) value)
+ (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (ldb (byte 8 56) value))))
+ (:bits-47-32
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
+ (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (ldb (byte 8 32) value)
+ (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (ldb (byte 8 40) value))))
+ (:ldah
+ (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
+ (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (ldb (byte 8 16) value)
+ (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (ldb (byte 8 24) value))))
+ (:lda
+ (setf (byte-vector-ref-8 gspace-bytes gspace-byte-offset)
+ (ldb (byte 8 0) value)
+ (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
+ (ldb (byte 8 8) value)))))
(:x86
(let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
gspace-byte-offset))
(code-object-start-addr (logandc2 (descriptor-bits code-object)
sb!vm:lowtag-mask)))
- (aver (= code-object-start-addr
+ (assert (= code-object-start-addr
(+ gspace-byte-address
(descriptor-byte-offset code-object))))
(ecase kind
(note-load-time-code-fixup code-object
after-header
value
- kind))))))
- ;; CMU CL supported these, and I haven't gone out of my way to break
- ;; them, but I have no way of testing them.. -- WHN 19990817
- #|
- (#.sb!c:hppa-fasl-file-implementation
- (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
- (setf (sap-ref-32 sap 0)
- (maybe-byte-swap
- (ecase kind
- (:load
- (logior (ash (ldb (byte 11 0) value) 1)
- (logand inst #xffffc000)))
- (:load-short
- (let ((low-bits (ldb (byte 11 0) value)))
- (aver (<= 0 low-bits (1- (ash 1 4))))
- (logior (ash low-bits 17)
- (logand inst #xffe0ffff))))
- (:hi
- (logior (ash (ldb (byte 5 13) value) 16)
- (ash (ldb (byte 2 18) value) 14)
- (ash (ldb (byte 2 11) value) 12)
- (ash (ldb (byte 11 20) value) 1)
- (ldb (byte 1 31) value)
- (logand inst #xffe00000)))
- (:branch
- (let ((bits (ldb (byte 9 2) value)))
- (aver (zerop (ldb (byte 2 0) value)))
- (logior (ash bits 3)
- (logand inst #xffe0e002)))))))))
- (#.sb!c:alpha-fasl-file-implementation
- (ecase kind
- (:jmp-hint
- (aver (zerop (ldb (byte 2 0) value)))
- #+nil
- (setf (sap-ref-16 sap 0)
- (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
- (:bits-63-48
- (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
- (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
- (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
- (setf (sap-ref-8 sap 0) (ldb (byte 8 48) value))
- (setf (sap-ref-8 sap 1) (ldb (byte 8 56) value))))
- (:bits-47-32
- (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
- (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
- (setf (sap-ref-8 sap 0) (ldb (byte 8 32) value))
- (setf (sap-ref-8 sap 1) (ldb (byte 8 40) value))))
- (:ldah
- (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
- (setf (sap-ref-8 sap 0) (ldb (byte 8 16) value))
- (setf (sap-ref-8 sap 1) (ldb (byte 8 24) value))))
- (:lda
- (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
- (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value)))))
- (#.sb!c:sgi-fasl-file-implementation
- (ecase kind
- (:jump
- (aver (zerop (ash value -28)))
- (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
- (ash value -2)))
- (:lui
- (setf (sap-ref-16 sap 2)
- (+ (ash value -16)
- (if (logbitp 15 value) 1 0))))
- (:addi
- (setf (sap-ref-16 sap 2)
- (ldb (byte 16 0) value)))))
- |#
- ))
+ kind)))))) ))
(values))
(defun resolve-assembler-fixups ()
--- /dev/null
+# -mcpu=pca56 makes _my_ alpha go fast, I'm told. Yours may do something
+# else.
+CFLAGS += -mcpu=pca56 -Dalpha
+LD = ld -taso
+LINKFLAGS = -v -g -Wl,-T -Wl,ld-script.alpha-linux
+NM = nm -p
+
+ASSEM_SRC = alpha-assem.S #linux-stubs.S
+ARCH_SRC = alpha-arch.c
+
+OS_SRC = linux-os.c os-common.c undefineds.c alpha-linux-os.c
+LINKFLAGS+=-static -rdynamic
+OS_LIBS= -ldl
+
+GC_SRC= gc.c
# stuff shared between various *BSD OSes
+CFLAGS += -DGENCGC
ASSEM_SRC = x86-assem.S
ARCH_SRC = x86-arch.c
ASSEM_SRC = x86-assem.S ldso-stubs.S
ARCH_SRC = x86-arch.c
-OS_SRC = linux-os.c os-common.c
+OS_SRC = linux-os.c x86-linux-os.c os-common.c
OS_LINK_FLAGS =
OS_LIBS = -ldl
GC_SRC= gencgc.c
+CFLAGS += -DGENCGC
\ No newline at end of file
# defaults which might be overridden or modified by values in the
# Config file
#
-# FIXME: The -fno-strength-reduce flag comes from before the fork
-# from CMU CL. It's presumably to work around some optimizer bug in gcc,
-# but the fork was a long time ago, and the optimizer could easily
-# have been fixed since then. Try doing without it.
-# CFLAGS = -g -Wall -O2 -fno-strength-reduce -DGENCGC
-CFLAGS = -g -Wall -O3 -DGENCGC
-ASFLAGS = -g -DGENCGC
+#
+CFLAGS = -g -Wall -O3
+ASFLAGS = $(CFLAGS)
DEPEND_FLAGS =
CPPFLAGS = -I.
+# Some of these things might be Config-dependent in future versions,
+# but they're the same on most systems right now. If you need to
+# override one of these, do it in Config
+CPP = cpp
+LD = ld
+LINKFLAGS = -g
+NM = nm -gp
+
# The Config file is the preferred place for tweaking options which
# are appropriate for particular setups (OS, CPU, whatever). Make a
# Config-foo file for setup foo, then arrange for Config to be a
# symlink to Config-foo.
include Config
-# Some of these things might be Config-dependent in future versions,
-# but they're not right now, i.e., they happen to be the same for
-# all supported systems.
-CPP = cpp
-GC_SRC = gencgc.c
-LD = ld
-LINKFLAGS = -g
-NM = nm -gp
SRCS = alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c globals.c interr.c interrupt.c \
sbcl: ${OBJS}
$(CC) ${LINKFLAGS} ${OS_LINK_FLAGS} -o $@ ${OBJS} ${OS_LIBS} -lm
+undefineds.o: undefineds.h undefineds.c
+
.PHONY: clean all
clean:
rm -f depend *.o sbcl sbcl.nm core *.tmp ; true
#include "alloc.h"
#include "globals.h"
#include "gc.h"
+#include <stdio.h>
#ifdef ibmrt
#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
(SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
#else
#define GET_FREE_POINTER() dynamic_space_free_pointer
-#define SET_FREE_POINTER(new_value) (dynamic_space_free_pointer = (new_value))
+#define SET_FREE_POINTER(new_value) \
+ (dynamic_space_free_pointer = (new_value))
#define GET_GC_TRIGGER() current_auto_gc_trigger
#define SET_GC_TRIGGER(new_value) \
clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
result = GET_FREE_POINTER();
+
SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
SET_GC_TRIGGER((char *)GET_FREE_POINTER()
- - (char *)DYNAMIC_SPACE_START);
+ - (char *)current_dynamic_space);
}
-
return result;
}
#endif
lispobj *result;
result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
-
*result = (lispobj) (words << type_Bits) | type;
-
return result;
}
lispobj alloc_sap(void *ptr)
{
- /* FIXME: It would probably be good to grep for "alpha" everywhere
- * and replace this kind of weirdness with nicer parameterizations
- * like N_WORDS_IN_POINTER. However, it might be hard to do this
- * well enough to be useful without an Alpha to test on. What to do? */
-#ifndef alpha
- struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 1);
-#else
- struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 3);
-#endif
- sap->pointer = ptr;
+ struct sap *sap = (struct sap *)alloc_unboxed
+ ((int)type_Sap,
+ ((sizeof (struct sap)) - (sizeof (lispobj))) / (sizeof (u32)));
+ sap->pointer = ptr;
return (lispobj) sap | type_OtherPointer;
}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/* note that although superficially it appears that we use
+ * os_context_t like we ought to, we actually just assume its a
+ * ucontext in places. Naughty */
+
+
+
+#include <stdio.h>
+#include <string.h>
+#include <asm/pal.h> /* for PAL_gentrap */
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "arch.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+
+extern char call_into_lisp_LRA[], call_into_lisp_end[];
+extern size_t os_vm_page_size;
+#define BREAKPOINT_INST 0x80
+
+void arch_init(void)
+{
+ /* this must be called _after_ os_init, so we know what the page size is */
+ if(mmap((os_vm_address_t) call_into_lisp_LRA_page,os_vm_page_size,
+ OS_VM_PROT_ALL,MAP_PRIVATE|MAP_ANONYMOUS|MAP_FIXED,-1,0)
+ == (os_vm_address_t) -1)
+ perror("mmap");
+
+ /* call_into_lisp_LRA is a collection of trampolines written in asm -
+ * see alpha-assem.S. We copy it to call_into_lisp_LRA_page where
+ * VOPs and things can find it (I don't know why they can't find it
+ * where it was to start with). */
+ bcopy(call_into_lisp_LRA,(void *)call_into_lisp_LRA_page,os_vm_page_size);
+
+ os_flush_icache((os_vm_address_t)call_into_lisp_LRA_page,
+ os_vm_page_size);
+ return;
+}
+
+os_vm_address_t
+arch_get_bad_addr (int sig, siginfo_t *code, os_context_t *context)
+{
+ unsigned int badinst;
+
+ /* instructions are 32 bit quantities */
+ unsigned int *pc ;
+ /* fprintf(stderr,"arch_get_bad_addr %d %p %p\n",
+ sig, code, context); */
+ pc= (unsigned int *)(*os_context_pc_addr(context));
+
+ if(((unsigned long)pc) & 3)
+ return NULL; /* in what case would pc be unaligned? */
+
+ if( (pc < READ_ONLY_SPACE_START ||
+ pc >= READ_ONLY_SPACE_START+READ_ONLY_SPACE_SIZE) &&
+ (pc < current_dynamic_space ||
+ pc >= current_dynamic_space + DYNAMIC_SPACE_SIZE))
+ return NULL;
+
+ badinst = *pc;
+
+ if(((badinst>>27)!=0x16) /* STL or STQ */
+ && ((badinst>>27)!=0x13)) /* STS or STT */
+ return NULL; /* Otherwise forget about address */
+
+ return (os_vm_address_t)
+ (*os_context_register_addr(context,((badinst>>16)&0x1f))
+ +(badinst&0xffff));
+}
+
+void arch_skip_instruction(os_context_t *context)
+{
+ /* this may be complete rubbish, as (at least for traps) pc points
+ * _after_ the instruction that caused us to be here anyway
+ */
+ ((char*)*os_context_pc_addr(context)) +=4; }
+
+unsigned char *arch_internal_error_arguments(os_context_t *context)
+{
+ return (unsigned char *)(*os_context_pc_addr(context)+4);
+}
+
+boolean arch_pseudo_atomic_atomic(os_context_t *context)
+{
+ return ((*os_context_register_addr(context,reg_ALLOC)) & 1);
+}
+
+void arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ /* On coming out of an atomic section, we subtract 1 from
+ * reg_Alloc, then try to store something at that address. On
+ * OSF/1 we add 1 to reg_Alloc here so that the end-of-atomic code
+ * will raise SIGTRAP for "unaligned access". Linux catches
+ * unaligned accesses in the kernel and fixes them up[1], so there
+ * we toggle bit 63 instead. The resulting address is somewhere
+ * out in no-man's land, so we get SIGSEGV when we try to access
+ * it. We catch whichever signal it is (see the appropriate
+ * *-os.c) and call interrupt_handle_pending() from it */
+
+ /* [1] This behaviour can be changed with osf_setsysinfo, but cmucl
+ * didn't use that */
+
+#ifdef linux
+ *os_context_register_addr(context,reg_ALLOC) |= (1L<<63);
+#else
+ *os_context_register_addr(context,reg_ALLOC) |= 2;
+#endif
+}
+
+/* XXX but is the caller of this storing all 64 bits? */
+unsigned long arch_install_breakpoint(void *pc)
+{
+ unsigned int *ptr = (unsigned int *)pc;
+ unsigned long result = (unsigned long) *ptr;
+ *ptr = BREAKPOINT_INST;
+ *(ptr+1)=trap_Breakpoint;
+
+ os_flush_icache((os_vm_address_t)ptr, sizeof(unsigned long));
+
+ return result;
+}
+
+void arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+ /* was (unsigned int) but gcc complains. Changed to mirror
+ install_breakpoint above */
+ unsigned long *ptr=(unsigned long *)pc;
+ *ptr = orig_inst;
+ os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
+}
+
+static unsigned int *skipped_break_addr, displaced_after_inst,
+ after_breakpoint;
+
+
+/* Returns a PC value. Lisp code is all in the 32-bit-addressable
+ space,so we should be ok with an unsigned int */
+
+unsigned int
+emulate_branch(os_context_t *context,unsigned long orig_inst)
+{
+ int op = orig_inst >> 26;
+ int reg_a = (orig_inst >> 21) & 0x1f;
+ int reg_b = (orig_inst >> 16) & 0x1f;
+ int fn = orig_inst & 0xffff;
+ int disp = (orig_inst&(1<<20)) ? orig_inst | (-1 << 21) : orig_inst&0x1fffff;
+ int next_pc = *os_context_pc_addr(context);
+ int branch = 0; /* was NULL; */
+
+ switch(op) {
+ case 0x1a: /* jmp, jsr, jsr_coroutine, ret */
+ *os_context_register_addr(context,reg_a)=*os_context_pc_addr(context);
+ *os_context_pc_addr(context)=*os_context_register_addr(context,reg_b)& ~3;
+ break;
+ case 0x30: /* br */
+ *os_context_register_addr(context,reg_a)=*os_context_pc_addr(context);
+ branch = 1;
+ break;
+ case 0x31: /* fbeq */
+ if(*(os_context_fpregister_addr(context,reg_a))==0) branch = 1;
+ break;
+ case 0x32: /* fblt */
+ if(*os_context_fpregister_addr(context,reg_a)<0) branch = 1;
+ break;
+ case 0x33: /* fble */
+ if(*os_context_fpregister_addr(context,reg_a)<=0) branch = 1;
+ break;
+ case 0x34: /* bsr */
+ *os_context_register_addr(context,reg_a)=*os_context_pc_addr(context);
+ branch = 1;
+ break;
+ case 0x35: /* fbne */
+ if(*os_context_register_addr(context,reg_a)!=0) branch = 1;
+ break;
+ case 0x36: /* fbge */
+ if(*os_context_fpregister_addr(context,reg_a)>=0) branch = 1;
+ break;
+ case 0x37: /* fbgt */
+ if(*os_context_fpregister_addr(context,reg_a)>0) branch = 1;
+ break;
+ case 0x38: /* blbc */
+ if((*os_context_register_addr(context,reg_a)&1) == 0) branch = 1;
+ break;
+ case 0x39: /* beq */
+ if(*os_context_register_addr(context,reg_a)==0) branch = 1;
+ break;
+ case 0x3a: /* blt */
+ if(*os_context_register_addr(context,reg_a)<0) branch = 1;
+ break;
+ case 0x3b: /* ble */
+ if(*os_context_register_addr(context,reg_a)<=0) branch = 1;
+ break;
+ case 0x3c: /* blbs */
+ if((*os_context_register_addr(context,reg_a)&1)!=0) branch = 1;
+ break;
+ case 0x3d: /* bne */
+ if(*os_context_register_addr(context,reg_a)!=0) branch = 1;
+ break;
+ case 0x3e: /* bge */
+ if(*os_context_register_addr(context,reg_a)>=0) branch = 1;
+ break;
+ case 0x3f: /* bgt */
+ if(*os_context_register_addr(context,reg_a)>0) branch = 1;
+ break;
+ }
+ if(branch) next_pc += disp*4;
+ return next_pc;
+}
+
+static sigset_t orig_sigmask;
+
+void arch_do_displaced_inst(os_context_t *context,unsigned int orig_inst)
+{
+ unsigned int *pc=(unsigned int *)(*os_context_pc_addr(context));
+ unsigned int *next_pc;
+ unsigned int next_inst;
+ int op = orig_inst >> 26;;
+ fprintf(stderr,"arch_do_displaced_inst depends on sigreturn, which is not implemented and will\nalways fail\n");
+ orig_sigmask = *os_context_sigmask_addr(context);
+ sigaddset_blockable(os_context_sigmask_addr(context));
+
+ /* Figure out where the displaced inst is going */
+ if(op == 0x1a || (op&0xf) == 0x30) /* branch...ugh */
+ /* the cast to long is just to shut gcc up */
+ next_pc = (unsigned int *)((long)emulate_branch(context,orig_inst));
+ else
+ next_pc = pc+1;
+
+ /* Put the original instruction back. */
+ *pc = orig_inst;
+ os_flush_icache((os_vm_address_t)pc, sizeof(unsigned long));
+ skipped_break_addr = pc;
+
+ /* set the after breakpoint */
+ displaced_after_inst = *next_pc;
+ *next_pc = BREAKPOINT_INST;
+ after_breakpoint=1;
+ os_flush_icache((os_vm_address_t)next_pc, sizeof(unsigned long));
+
+ ldb_monitor("sigreturn is not implemented and just failed");
+ sigreturn(context);
+}
+
+#define AfterBreakpoint 100
+
+static void sigill_handler(int signal, siginfo_t *siginfo, os_context_t *context) {
+ fake_foreign_function_call(context);
+ ldb_monitor();
+}
+
+static void sigtrap_handler(int signal, siginfo_t *siginfo, os_context_t *context)
+{
+ /* Don't disallow recursive breakpoint traps. Otherwise, we can't */
+ /* use debugger breakpoints anywhere in here. */
+
+ sigset_t *mask=(os_context_sigmask_addr(context));
+ unsigned int code;
+ fprintf(stderr,"sigtrap_handler:signal %d context=%p ",signal,context);
+ sigsetmask(mask);
+
+ /* this is different from how CMUCL does it. CMUCL used
+ * "call_pal PAL_gentrap", which doesn't do anything on Linux
+ * so screwed up our offsets in odd ways. We use "bpt" instead
+ */
+
+ /* probably we should
+ assert(*(unsigned int*)(*os_context_pc_addr(context)-4) == BREAKPOINT_INST)
+ but I've not decided a good way to handle it if it turns out not to be
+ */
+ code=*((u32 *)(*os_context_pc_addr(context)));
+ fprintf(stderr,"pc=%lx code=%d, inst=%x\n",
+ *os_context_pc_addr(context), code,
+ *(unsigned int*)(*os_context_pc_addr(context)-4));
+ switch (code) {
+ case trap_PendingInterrupt:
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ break;
+
+ case trap_Halt:
+ fake_foreign_function_call(context);
+ lose("%%primitive halt called; the party is over.\n");
+
+ case trap_Error:
+ case trap_Cerror:
+ interrupt_internal_error(signal, siginfo, context, code==trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ *os_context_pc_addr(context) -=4;
+ handle_breakpoint(signal, siginfo, context);
+ break;
+
+ case trap_FunctionEndBreakpoint:
+ *os_context_pc_addr(context) -=4;
+ *os_context_pc_addr(context) = (int)handle_function_end_breakpoint(signal, siginfo, context);
+ break;
+
+ case AfterBreakpoint:
+ *os_context_pc_addr(context) -=4;
+ *skipped_break_addr = BREAKPOINT_INST;
+ os_flush_icache((os_vm_address_t)skipped_break_addr,
+ sizeof(unsigned long));
+ skipped_break_addr = NULL;
+ *(unsigned int *)*os_context_pc_addr(context) = displaced_after_inst;
+ os_flush_icache((os_vm_address_t)*os_context_pc_addr(context), sizeof(unsigned long));
+ *os_context_sigmask_addr(context)= orig_sigmask;
+ after_breakpoint=0; /* NULL; */
+ break;
+
+ default:
+ interrupt_handle_now(signal, siginfo, context);
+ break;
+ }
+}
+
+#define FIXNUM_VALUE(lispobj) (((int)lispobj)>>2)
+
+static void sigfpe_handler(int signal, int code, os_context_t *context)
+{
+}
+
+void arch_install_interrupt_handlers()
+{
+ interrupt_install_low_level_handler(SIGILL,sigill_handler);
+ interrupt_install_low_level_handler(SIGTRAP,sigtrap_handler);
+ interrupt_install_low_level_handler(SIGFPE,sigfpe_handler);
+}
+
+extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
+
+lispobj funcall0(lispobj function)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ return call_into_lisp(function, args, 0);
+}
+
+lispobj funcall1(lispobj function, lispobj arg0)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 1;
+ args[0] = arg0;
+
+ return call_into_lisp(function, args, 1);
+}
+
+lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 2;
+ args[0] = arg0;
+ args[1] = arg1;
+
+ return call_into_lisp(function, args, 2);
+}
+
+lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+ lispobj *args = current_control_stack_pointer;
+
+ current_control_stack_pointer += 3;
+ args[0] = arg0;
+ args[1] = arg1;
+ args[2] = arg2;
+
+ return call_into_lisp(function, args, 3);
+}
+
+
+/* This is apparently called by emulate_branch, but isn't defined. So */
+/* just do nothing and hope it works... */
+
+void cacheflush(void)
+{
+ /* hoping probably isn't _actually_ enough. we should call_pal imb,
+ according to the arch ref manual
+ */
+}
--- /dev/null
+#include "validate.h"
+#include <alpha/regdef.h>
+#include <asm/pal.h>
+
+#include "sbcl.h"
+#include "lispregs.h"
+/* #include "globals.h" */
+
+/*
+ * Function to transfer control into lisp.
+ */
+ .text
+ .align 4
+ .globl call_into_lisp
+ .ent call_into_lisp
+call_into_lisp:
+#define framesize 8*8
+ ldgp gp, 0($27)
+ /* Save all the C regs. */
+ lda sp,-framesize(sp)
+ stq ra, framesize-8*8(sp)
+ stq s0, framesize-8*7(sp)
+ stq s1, framesize-8*6(sp)
+ stq s2, framesize-8*5(sp)
+ stq s3, framesize-8*4(sp)
+ stq s4, framesize-8*3(sp)
+ stq s5, framesize-8*2(sp)
+ stq s6, framesize-8*1(sp)
+ .mask 0x0fc001fe, -framesize
+ .frame sp,framesize,ra
+
+ /* Clear descriptor regs */
+ ldil reg_CODE,0
+ ldil reg_FDEFN,0
+ mov a0,reg_LEXENV
+ sll a2,2,reg_NARGS
+ ldil reg_OCFP,0
+ ldil reg_LRA,0
+ ldil reg_L0,0
+ ldil reg_L1,0
+
+
+ /* Establish NIL. */
+ ldil reg_NULL,NIL
+
+ /* The CMUCL comment here is "Start pseudo-atomic.", but */
+ /* there's no obvious code that would have that effect */
+
+ /* No longer in foreign call. */
+ stl zero,foreign_function_call_active
+
+ /* Load lisp state. */
+ ldl reg_ALLOC,dynamic_space_free_pointer
+ ldl reg_BSP,current_binding_stack_pointer
+ ldl reg_CSP,current_control_stack_pointer
+ ldl reg_OCFP,current_control_frame_pointer
+ mov a1,reg_CFP
+
+ .set noat
+ ldil reg_L2,0
+ .set at
+
+ /* End of pseudo-atomic. */
+
+ /* Establish lisp arguments. */
+ ldl reg_A0,0(reg_CFP)
+ ldl reg_A1,4(reg_CFP)
+ ldl reg_A2,8(reg_CFP)
+ ldl reg_A3,12(reg_CFP)
+ ldl reg_A4,16(reg_CFP)
+ ldl reg_A5,20(reg_CFP)
+
+ /* This call will 'return' into the LRA page below */
+ lda reg_LRA,call_into_lisp_LRA_page+type_OtherPointer
+
+ /* Indirect the closure */
+ ldl reg_CODE,CLOSURE_FUNCTION_OFFSET(reg_LEXENV)
+ addl reg_CODE,6*4-type_FunctionPointer,reg_LIP
+
+ /* And into lisp we go. */
+ jsr reg_ZERO,(reg_LIP)
+
+
+ /* a page of the following code (from call_into_lisp_LRA
+ onwards) is copied into the LRA page at arch_init() time. */
+
+ .set noreorder
+ .align 3
+ .globl call_into_lisp_LRA
+call_into_lisp_LRA:
+
+ .long type_ReturnPcHeader
+
+ /* execution resumes here*/
+ mov reg_OCFP,reg_CSP
+ nop
+
+ /* return value already there */
+ mov reg_A0,v0
+
+ /* Turn on pseudo-atomic. */
+
+ /* Save LISP registers */
+ stl reg_ALLOC, dynamic_space_free_pointer
+ stl reg_BSP,current_binding_stack_pointer
+ stl reg_CSP,current_control_stack_pointer
+ stl reg_CFP,current_control_frame_pointer
+
+ /* Back in C land. [CSP is just a handy non-zero value.] */
+ stl reg_CSP,foreign_function_call_active
+
+ /* Turn off pseudo-atomic and check for traps. */
+
+ /* Restore C regs */
+ ldq ra, framesize-8*8(sp)
+ ldq s0, framesize-8*7(sp)
+ ldq s1, framesize-8*6(sp)
+ ldq s2, framesize-8*5(sp)
+ ldq s3, framesize-8*4(sp)
+ ldq s4, framesize-8*3(sp)
+ ldq s5, framesize-8*2(sp)
+ ldq s6, framesize-8*1(sp)
+
+ /* Restore the C stack! */
+ lda sp, framesize(sp)
+
+ ret zero,(ra),1
+ .globl call_into_lisp_end
+call_into_lisp_end:
+ .end call_into_lisp
+
+/*
+ * Transfering control from Lisp into C. reg_CFUNC (t10, 24) contains
+ * the address of the C function to call
+ */
+ .set noreorder
+ .text
+ .align 4
+ .globl call_into_c
+ .ent call_into_c
+call_into_c:
+ .mask 0x0fc001fe, -12
+ .frame sp,12,ra
+ mov reg_CFP, reg_OCFP
+ mov reg_CSP, reg_CFP
+ addq reg_CFP, 32, reg_CSP
+ stl reg_OCFP, 0(reg_CFP)
+ subl reg_LIP, reg_CODE, reg_L1
+ addl reg_L1, type_OtherPointer, reg_L1
+ stl reg_L1, 4(reg_CFP)
+ stl reg_CODE, 8(reg_CFP)
+ stl reg_NULL, 12(reg_CFP)
+
+ /* Set the pseudo-atomic flag. */
+ addq reg_ALLOC,1,reg_ALLOC
+
+ /* Get the top two register args and fix the NSP to point to arg 7 */
+ ldq reg_NL4,0(reg_NSP)
+ ldq reg_NL5,8(reg_NSP)
+ addq reg_NSP,16,reg_NSP
+
+ /* Save lisp state. */
+ subq reg_ALLOC,1,reg_L1
+ stl reg_L1, dynamic_space_free_pointer
+ stl reg_BSP, current_binding_stack_pointer
+ stl reg_CSP, current_control_stack_pointer
+ stl reg_CFP, current_control_frame_pointer
+
+ /* Mark us as in C land. */
+ stl reg_CSP, foreign_function_call_active
+
+ /* Were we interrupted? */
+ subq reg_ALLOC,1,reg_ALLOC
+ stl reg_ZERO,0(reg_ALLOC)
+
+ /* Into C land we go. */
+
+ /* L1 is pv (procedure variable). The following line is */
+ /* apparently a jump hint and not mysterious at all */
+
+ /* <dhd> so, you have perfectly good code with comments written by */
+ /* people who don't understand the Alpha :) */
+
+ mov reg_CFUNC, reg_L1 /* ### This line is a mystery */
+
+ jsr ra, (reg_CFUNC)
+ ldgp $29,0(ra)
+
+ /* restore NSP */
+ subq reg_NSP,16,reg_NSP
+
+ /* Clear unsaved descriptor regs */
+ mov reg_ZERO, reg_NARGS
+ mov reg_ZERO, reg_A0
+ mov reg_ZERO, reg_A1
+ mov reg_ZERO, reg_A2
+ mov reg_ZERO, reg_A3
+ mov reg_ZERO, reg_A4
+ mov reg_ZERO, reg_A5
+ mov reg_ZERO, reg_L0
+ .set noat
+ mov reg_ZERO, reg_L2
+ .set at
+
+ /* Turn on pseudo-atomic. */
+ lda reg_ALLOC,1(reg_ZERO)
+
+ /* Mark us at in Lisp land. */
+ stl reg_ZERO, foreign_function_call_active
+
+ /* Restore ALLOC, preserving pseudo-atomic-atomic */
+ ldl reg_NL0,dynamic_space_free_pointer
+ addq reg_ALLOC,reg_NL0,reg_ALLOC
+
+ /* Check for interrupt */
+ subq reg_ALLOC,1,reg_ALLOC
+ stl reg_ZERO,0(reg_ALLOC)
+
+ ldl reg_NULL, 12(reg_CFP)
+
+ /* Restore LRA & CODE (they may have been GC'ed) */
+ /* can you see anything here which touches LRA? I can't ...*/
+ ldl reg_CODE, 8(reg_CFP)
+ ldl reg_NL0, 4(reg_CFP)
+ subq reg_NL0, type_OtherPointer, reg_NL0
+ addq reg_CODE, reg_NL0, reg_NL0
+
+ mov reg_CFP, reg_CSP
+ mov reg_OCFP, reg_CFP
+
+ ret zero, (reg_NL0), 1
+
+ .end call_into_c
+
+ .text
+ .globl start_of_tramps
+start_of_tramps:
+
+/*
+ * The undefined-function trampoline. Causes a trap_Error trap which
+ * sigtrap_handler catches and eventaully calls the Lisp
+ * INTERNAL-ERROR function
+ */
+ .text
+ .globl undefined_tramp
+ .ent undefined_tramp_offset
+undefined_tramp = /* ### undefined_tramp_offset-call_into_lisp_LRA*/ 0x140+call_into_lisp_LRA_page
+undefined_tramp_offset:
+ bpt
+ .long trap_Error
+ .byte 4 /* what are these numbers? */
+ .byte 23
+ .byte 254
+ .byte (0xe0 + sc_DescriptorReg)
+ .byte 2
+ .align 2
+ .end undefined_tramp
+
+
+/*
+ * The closure trampoline.
+ */
+ .text
+ .globl closure_tramp
+ .ent closure_tramp_offset
+closure_tramp = /* ### */ 0x150 + call_into_lisp_LRA_page
+closure_tramp_offset:
+ ldl reg_LEXENV, FDEFN_FUNCTION_OFFSET(reg_FDEFN)
+ ldl reg_L0, CLOSURE_FUNCTION_OFFSET(reg_LEXENV)
+ addl reg_L0, FUNCTION_CODE_OFFSET, reg_LIP
+ jmp reg_ZERO,(reg_LIP)
+ .end closure_tramp
+
+ .text
+ .globl end_of_tramps
+end_of_tramps:
+
+
+/*
+ * Function-end breakpoint magic.
+ */
+
+ .text
+ .align 2
+ .set noreorder
+ .globl function_end_breakpoint_guts
+function_end_breakpoint_guts:
+ .long type_ReturnPcHeader
+ br zero, function_end_breakpoint_trap
+ nop
+ mov reg_CSP, reg_OCFP
+ addl reg_CSP, 4, reg_CSP
+ addl zero, 4, reg_NARGS
+ mov reg_NULL, reg_A1
+ mov reg_NULL, reg_A2
+ mov reg_NULL, reg_A3
+ mov reg_NULL, reg_A4
+ mov reg_NULL, reg_A5
+1:
+
+ .globl function_end_breakpoint_trap
+function_end_breakpoint_trap:
+ call_pal PAL_gentrap
+ .long trap_FunctionEndBreakpoint
+ br zero, function_end_breakpoint_trap
+
+ .globl function_end_breakpoint_end
+function_end_breakpoint_end:
+
+
--- /dev/null
+/*
+ * The x86 Linux incarnation of arch-dependent OS-dependent routines.
+ * See also linux-os.c
+ */
+
+
+/* header files lifted wholesale from linux-os.c, some may be redundant */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+#if defined GENCGC /* unlikely ... */
+#include "gencgc.h"
+#endif
+
+sigcontext_register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ return &context->uc_mcontext.sc_regs[offset];
+}
+
+sigcontext_register_t *
+os_context_fpregister_addr(os_context_t *context, int offset)
+{
+ return &context->uc_mcontext.sc_fpregs[offset];
+}
+
+sigcontext_register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ return &((context->uc_mcontext).sc_pc);
+}
+sigcontext_register_t *
+os_context_sp_addr(os_context_t *context)
+{
+ lose("This was supposed to be an x86-only operation");
+ return 0;
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &context->uc_sigmask;
+}
+
+void os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+ /* XXX this really shouldn't be empty
+
+<dhd> dan_b: asm volatile ("call_pal imb")
+<dhd> or just "imb"
+<dhd> also : : "memory"
+
+ */
+}
--- /dev/null
+
+#define NREGS (32)
+
+#ifdef LANGUAGE_ASSEMBLY
+#define REG(num) $##num
+#else
+#define REG(num) num
+#endif
+ /* "traditional" register name and use */
+ /* courtesy of <alpha/regdef.h> */
+#define reg_LIP REG(0) /* v0 */
+#define reg_A0 REG(1) /* t0 - temporary (caller-saved) */
+#define reg_A1 REG(2) /* t1 */
+#define reg_A2 REG(3) /* t2 */
+#define reg_A3 REG(4) /* t3 */
+#define reg_A4 REG(5) /* t4 */
+#define reg_A5 REG(6) /* t5 */
+#define reg_L0 REG(7) /* t6 */
+#define reg_NARGS REG(8) /* t7 */
+#define reg_CSP REG(9) /* s0 - saved (callee-saved) */
+#define reg_CFP REG(10) /* s1 */
+#define reg_OCFP REG(11) /* s2 */
+#define reg_BSP REG(12) /* s3 */
+#define reg_LEXENV REG(13) /* s4 */
+#define reg_CODE REG(14) /* s5 */
+#define reg_NULL REG(15) /* s6 = fp (frame pointer) */
+#define reg_NL0 REG(16) /* a0 - argument (caller-saved) */
+#define reg_NL1 REG(17) /* a1 */
+#define reg_NL2 REG(18) /* a2 */
+#define reg_NL3 REG(19) /* a3 */
+#define reg_NL4 REG(20) /* a4 */
+#define reg_NL5 REG(21) /* a5 */
+#define reg_ALLOC REG(22) /* t8 - more temps (caller-saved) */
+#define reg_FDEFN REG(23) /* t9 */
+#define reg_CFUNC REG(24) /* t10 */
+#define reg_NFP REG(25) /* t11 */
+#define reg_LRA REG(26) /* ra - return address */
+#define reg_L1 REG(27) /* t12, or pv - procedure variable */
+#define reg_L2 REG(28) /* at - assembler temporary */
+#define reg_GP REG(29) /* global pointer */
+#define reg_NSP REG(30) /* sp - stack pointer */
+#define reg_ZERO REG(31) /* reads as zero, writes are noops */
+
+
+#define REGNAMES \
+ "LIP", "A0", "A1", "A2", "A3", "A4", "A5", "L0", "NARGS", \
+ "CSP", "CFP", "OCFP", "BSP", "LEXENV", "CODE", "NULL", \
+ "NL0", "NL1", "NL2", "NL3", "NL4", "NL5", "ALLOC", "FDEFN", \
+ "CFUNC", "NFP", "LRA", "L1", "L2", "GP", "NSP", "ZERO"
+
+#define BOXED_REGISTERS { \
+ reg_CODE, reg_FDEFN, reg_LEXENV, reg_NARGS, reg_OCFP, reg_LRA, \
+ reg_A0, reg_A1, reg_A2, reg_A3, reg_A4, reg_A5, \
+ reg_L0, reg_L1, reg_L2 \
+}
+
+
+#define call_into_lisp_LRA_page 0x10000
--- /dev/null
+/*
+
+ $Header$
+
+ This code was written as part of the CMU Common Lisp project at
+ Carnegie Mellon University, and has been placed in the public domain.
+
+*/
+#error "this file is dead"
extern void arch_remove_breakpoint(void *pc, unsigned long orig_inst);
extern void arch_install_interrupt_handlers(void);
extern void arch_do_displaced_inst(os_context_t *context,
- unsigned long orig_inst);
+ unsigned int orig_inst);
extern lispobj funcall0(lispobj function);
extern lispobj funcall1(lispobj function, lispobj arg0);
extern lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1);
static boolean
cs_valid_pointer_p(struct call_frame *pointer)
{
- lose("stub: hasn't been updated for X86");
+ /* lose("stub: hasn't been updated for X86"); */
return (((char *) CONTROL_STACK_START <= (char *) pointer) &&
((char *) pointer < (char *) current_control_stack_pointer));
}
for (entry = (struct ndir_entry *) ptr; --count>= 0; ++entry) {
long id = entry->identifier;
- long offset = CORE_PAGESIZE * (1 + entry->data_page);
+ long offset = os_vm_page_size * (1 + entry->data_page);
os_vm_address_t addr =
- (os_vm_address_t) (CORE_PAGESIZE * entry->address);
+ (os_vm_address_t) (os_vm_page_size * entry->address);
lispobj *free_pointer = (lispobj *) addr + entry->nwords;
- long len = CORE_PAGESIZE * entry->page_count;
+ long len = os_vm_page_size * entry->page_count;
if (len != 0) {
os_vm_address_t real_addr;
switch (id) {
case DYNAMIC_SPACE_ID:
+#ifdef GENCGC
if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) {
- lose("core/runtime address mismatch: DYNAMIC_SPACE_START");
+ fprintf(stderr, "in core: 0x%x - in runtime: 0x%x \n",
+ addr, (os_vm_address_t)DYNAMIC_SPACE_START);
+ fprintf(stderr,"warning: core/runtime address mismatch: DYNAMIC_SPACE_START");
}
+#else
+ if ((addr != (os_vm_address_t)DYNAMIC_0_SPACE_START) &&
+ (addr != (os_vm_address_t)DYNAMIC_1_SPACE_START)) {
+ fprintf(stderr, "in core: 0x%x - in runtime: 0x%x or 0x%x\n",
+ addr, (os_vm_address_t)DYNAMIC_0_SPACE_START,
+ (os_vm_address_t)DYNAMIC_1_SPACE_START);
+ fprintf(stderr,"warning: core/runtime address mismatch: DYNAMIC_SPACE_START");
+ }
+#endif
#if defined(ibmrt) || defined(__i386__)
SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
#else
dynamic_space_free_pointer = free_pointer;
#endif
+ /* on the x86, this will always be space 0 */
+ current_dynamic_space = (lispobj *)addr;
break;
case STATIC_SPACE_ID:
if (addr != (os_vm_address_t)STATIC_SPACE_START) {
+ fprintf(stderr, "in core: 0x%p - in runtime: 0x%x\n",
+ addr, (os_vm_address_t)STATIC_SPACE_START);
lose("core/runtime address mismatch: STATIC_SPACE_START");
}
break;
case READ_ONLY_SPACE_ID:
if (addr != (os_vm_address_t)READ_ONLY_SPACE_START) {
+ fprintf(stderr, "in core: 0x%x - in runtime: 0x%x\n",
+ addr, (os_vm_address_t)READ_ONLY_SPACE_START);
lose("core/runtime address mismatch: READ_ONLY_SPACE_START");
}
break;
default:
- lose("unknown space ID %ld", id);
+ lose("unknown space ID %ld addr 0x%p", id);
}
}
}
* a typedef like addr_as_int once and for all in each
* architecture file, then use that everywhere. -- WHN 19990904 */
#ifndef alpha
- long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
+ long *header, val, len, *ptr;
long remaining_len;
#else
- u32 header[CORE_PAGESIZE / sizeof(u32)], val, len, *ptr;
+ u32 *header, val, len, *ptr;
u32 remaining_len;
#endif
lispobj initial_function = NIL;
-
if (fd < 0) {
fprintf(stderr, "could not open file \"%s\"\n", file);
perror("open");
exit(1);
}
- count = read(fd, header, CORE_PAGESIZE);
- if (count < CORE_PAGESIZE) {
+ header=calloc(os_vm_page_size / sizeof(u32),sizeof(u32));
+
+ count = read(fd, header, os_vm_page_size);
+ if (count < os_vm_page_size) {
lose("premature end of core file");
}
ptr += remaining_len;
}
-
+ free(header);
return initial_function;
}
--- /dev/null
+/*
+ * Stop and Copy GC based on Cheney's algorithm.
+ *
+ * $Header$
+ *
+ * Written by Christopher Hoover.
+ */
+
+
+#include <stdio.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+#include <signal.h>
+#include "runtime.h"
+#include "sbcl.h"
+#include "os.h"
+#include "gc.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "validate.h"
+#include "lispregs.h"
+#include "interr.h"
+#if 0
+#define PRINTNOISE
+#define DEBUG_SPACE_PREDICATES
+#define DEBUG_SCAVENGE_VERBOSE
+#define DEBUG_COPY_VERBOSE
+#define DEBUG_CODE_GC
+#endif
+
+static lispobj *from_space;
+static lispobj *from_space_free_pointer;
+
+static lispobj *new_space;
+static lispobj *new_space_free_pointer;
+
+static int (*scavtab[256])(lispobj *where, lispobj object);
+static lispobj (*transother[256])(lispobj object);
+static int (*sizetab[256])(lispobj *where);
+
+static struct weak_pointer *weak_pointers;
+
+static void scavenge(lispobj *start, u32 nwords);
+static void scavenge_newspace(void);
+static void scavenge_interrupt_contexts(void);
+static void scan_weak_pointers(void);
+static int scav_lose(lispobj *where, lispobj object);
+
+#define gc_abort() lose("GC invariant lost! File \"%s\", line %d\n", \
+ __FILE__, __LINE__)
+
+#if 1
+#define gc_assert(ex) do { \
+ if (!(ex)) gc_abort(); \
+} while (0)
+#else
+#define gc_assert(ex)
+#endif
+
+#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
+
+\f
+/* Predicates */
+
+#if defined(DEBUG_SPACE_PREDICATES)
+
+boolean from_space_p(lispobj object)
+{
+ lispobj *ptr;
+
+ /* this can be called for untagged pointers as well as for
+ descriptors, so this assertion's not applicable
+ gc_assert(Pointerp(object));
+ */
+ ptr = (lispobj *) PTR(object);
+
+ return ((from_space <= ptr) &&
+ (ptr < from_space_free_pointer));
+}
+
+boolean new_space_p(lispobj object)
+{
+ lispobj *ptr;
+
+ gc_assert(Pointerp(object));
+
+ ptr = (lispobj *) PTR(object);
+
+ return ((new_space <= ptr) &&
+ (ptr < new_space_free_pointer));
+}
+
+#else
+
+#define from_space_p(ptr) \
+ ((from_space <= ((lispobj *) ptr)) && \
+ (((lispobj *) ptr) < from_space_free_pointer))
+
+#define new_space_p(ptr) \
+ ((new_space <= ((lispobj *) ptr)) && \
+ (((lispobj *) ptr) < new_space_free_pointer))
+
+#endif
+
+\f
+/* Copying Objects */
+
+static lispobj
+copy_object(lispobj object, int nwords)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+
+ gc_assert(Pointerp(object));
+ gc_assert(from_space_p(object));
+ gc_assert((nwords & 0x01) == 0);
+
+ /* get tag of object */
+ tag = LowtagOf(object);
+
+ /* allocate space */
+ new = new_space_free_pointer;
+ new_space_free_pointer += nwords;
+
+ dest = new;
+ source = (lispobj *) PTR(object);
+
+#ifdef DEBUG_COPY_VERBOSE
+ fprintf(stderr,"Copying %d words from %p to %p\n", nwords,source,new);
+#endif
+
+ /* copy the object */
+ while (nwords > 0) {
+ dest[0] = source[0];
+ dest[1] = source[1];
+ dest += 2;
+ source += 2;
+ nwords -= 2;
+ }
+ /* return lisp pointer of new object */
+ return (lispobj)(LOW_WORD(new) | tag);
+}
+
+\f
+/* Collect Garbage */
+
+#ifdef PRINTNOISE
+static double tv_diff(struct timeval *x, struct timeval *y)
+{
+ return (((double) x->tv_sec + (double) x->tv_usec * 1.0e-6) -
+ ((double) y->tv_sec + (double) y->tv_usec * 1.0e-6));
+}
+#endif
+
+#define BYTES_ZERO_BEFORE_END (1<<12)
+
+#ifdef alpha
+#define U32 u32
+#else
+#define U32 unsigned long
+#endif
+static void zero_stack(void)
+{
+ U32 *ptr = (U32 *)current_control_stack_pointer;
+ search:
+ do {
+ if (*ptr)
+ goto fill;
+ ptr++;
+ } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
+ return;
+ fill:
+ do {
+ *ptr++ = 0;
+ } while (((unsigned long)ptr) & (BYTES_ZERO_BEFORE_END-1));
+
+ goto search;
+}
+#undef U32
+
+
+/* this is not generational. It's called with a last_gen arg, which we shun.
+ */
+
+void collect_garbage(unsigned ignore)
+{
+#ifdef PRINTNOISE
+struct timeval start_tv, stop_tv;
+ struct rusage start_rusage, stop_rusage;
+ double real_time, system_time, user_time;
+ double percent_retained, gc_rate;
+ unsigned long size_discarded;
+ unsigned long size_retained;
+#endif
+ lispobj *current_static_space_free_pointer;
+ unsigned long static_space_size;
+ unsigned long control_stack_size, binding_stack_size;
+ sigset_t tmp, old;
+
+#ifdef PRINTNOISE
+ printf("[Collecting garbage ... \n");
+
+ getrusage(RUSAGE_SELF, &start_rusage);
+ gettimeofday(&start_tv, (struct timezone *) 0);
+#endif
+
+ sigemptyset(&tmp);
+ sigaddset_blockable(&tmp);
+ sigprocmask(SIG_BLOCK, &tmp, &old);
+
+ current_static_space_free_pointer =
+ (lispobj *) ((unsigned long)
+ SymbolValue(STATIC_SPACE_FREE_POINTER));
+
+
+ /* Set up from space and new space pointers. */
+
+ from_space = current_dynamic_space;
+#ifndef ibmrt
+ from_space_free_pointer = dynamic_space_free_pointer;
+#else
+ from_space_free_pointer = (lispobj *)SymbolValue(ALLOCATION_POINTER);
+#endif
+
+ fprintf(stderr,"from_space = %lx\n",
+ (unsigned long) current_dynamic_space);
+ if (current_dynamic_space == (lispobj *) DYNAMIC_0_SPACE_START)
+ new_space = (lispobj *)DYNAMIC_1_SPACE_START;
+ else if (current_dynamic_space == (lispobj *) DYNAMIC_1_SPACE_START)
+ new_space = (lispobj *) DYNAMIC_0_SPACE_START;
+ else {
+ lose("GC lossage. Current dynamic space is bogus!\n");
+ }
+ new_space_free_pointer = new_space;
+
+
+ /* Initialize the weak pointer list. */
+ weak_pointers = (struct weak_pointer *) NULL;
+
+
+ /* Scavenge all of the roots. */
+#ifdef PRINTNOISE
+ printf("Scavenging interrupt contexts ...\n");
+#endif
+ scavenge_interrupt_contexts();
+
+#ifdef PRINTNOISE
+ printf("Scavenging interrupt handlers (%d bytes) ...\n",
+ (int)sizeof(interrupt_handlers));
+#endif
+ scavenge((lispobj *) interrupt_handlers,
+ sizeof(interrupt_handlers) / sizeof(lispobj));
+
+ /* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
+ control_stack_size =
+ current_control_stack_pointer-
+ (lispobj *)CONTROL_STACK_START;
+#ifdef PRINTNOISE
+ printf("Scavenging the control stack at %p (%ld words) ...\n",
+ ((lispobj *)CONTROL_STACK_START),
+ control_stack_size);
+#endif
+ scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
+
+
+#ifdef ibmrt
+ binding_stack_size =
+ (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack;
+#else
+ binding_stack_size =
+ current_binding_stack_pointer -
+ (lispobj *)BINDING_STACK_START;
+#endif
+#ifdef PRINTNOISE
+ printf("Scavenging the binding stack %x - %x (%d words) ...\n",
+ BINDING_STACK_START,current_binding_stack_pointer,
+ (int)(binding_stack_size));
+#endif
+ scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
+
+ static_space_size =
+ current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
+#ifdef PRINTNOISE
+ printf("Scavenging static space %x - %x (%d words) ...\n",
+ STATIC_SPACE_START,current_static_space_free_pointer,
+ (int)(static_space_size));
+#endif
+ scavenge(((lispobj *)STATIC_SPACE_START), static_space_size);
+
+ /* Scavenge newspace. */
+#ifdef PRINTNOISE
+ printf("Scavenging new space (%d bytes) ...\n",
+ (int)((new_space_free_pointer - new_space) * sizeof(lispobj)));
+#endif
+ scavenge_newspace();
+
+
+#if defined(DEBUG_PRINT_GARBAGE)
+ print_garbage(from_space, from_space_free_pointer);
+#endif
+
+ /* Scan the weak pointers. */
+#ifdef PRINTNOISE
+ printf("Scanning weak pointers ...\n");
+#endif
+ scan_weak_pointers();
+
+
+ /* Flip spaces. */
+#ifdef PRINTNOISE
+ printf("Flipping spaces ...\n");
+#endif
+
+ os_zero((os_vm_address_t) current_dynamic_space,
+ (os_vm_size_t) DYNAMIC_SPACE_SIZE);
+
+ current_dynamic_space = new_space;
+#ifndef ibmrt
+ dynamic_space_free_pointer = new_space_free_pointer;
+#else
+ SetSymbolValue(ALLOCATION_POINTER, (lispobj)new_space_free_pointer);
+#endif
+
+#ifdef PRINTNOISE
+ size_discarded = (from_space_free_pointer - from_space) * sizeof(lispobj);
+ size_retained = (new_space_free_pointer - new_space) * sizeof(lispobj);
+#endif
+
+ /* Zero stack. */
+#ifdef PRINTNOISE
+ printf("Zeroing empty part of control stack ...\n");
+#endif
+ zero_stack();
+
+ sigprocmask(SIG_SETMASK, &old, 0);
+
+
+#ifdef PRINTNOISE
+ gettimeofday(&stop_tv, (struct timezone *) 0);
+ getrusage(RUSAGE_SELF, &stop_rusage);
+
+ printf("done.]\n");
+
+ percent_retained = (((float) size_retained) /
+ ((float) size_discarded)) * 100.0;
+
+ printf("Total of %ld bytes out of %ld bytes retained (%3.2f%%).\n",
+ size_retained, size_discarded, percent_retained);
+
+ real_time = tv_diff(&stop_tv, &start_tv);
+ user_time = tv_diff(&stop_rusage.ru_utime, &start_rusage.ru_utime);
+ system_time = tv_diff(&stop_rusage.ru_stime, &start_rusage.ru_stime);
+
+#if 0
+ printf("Statistics:\n");
+ printf("%10.2f sec of real time\n", real_time);
+ printf("%10.2f sec of user time,\n", user_time);
+ printf("%10.2f sec of system time.\n", system_time);
+#else
+ printf("Statistics: %10.2fs real, %10.2fs user, %10.2fs system.\n",
+ real_time, user_time, system_time);
+#endif
+
+ gc_rate = ((float) size_retained / (float) (1<<20)) / real_time;
+
+ printf("%10.2f M bytes/sec collected.\n", gc_rate);
+#endif
+}
+
+\f
+/* Scavenging */
+
+#define DIRECT_SCAV 0
+
+static void
+scavenge(lispobj *start, u32 nwords)
+{
+ while (nwords > 0) {
+ lispobj object;
+ int type, words_scavenged;
+
+ object = *start;
+ type = TypeOf(object);
+
+#if defined(DEBUG_SCAVENGE_VERBOSE)
+ fprintf(stderr,"Scavenging object at 0x%08x, object = 0x%08x, type = %d\n",
+ (unsigned long) start, (unsigned long) object, type);
+#endif
+
+#if DIRECT_SCAV
+ words_scavenged = (scavtab[type])(start, object);
+#else
+ if (Pointerp(object)) {
+ /* It be a pointer. */
+ if (from_space_p(object)) {
+ /* It currently points to old space. Check for a */
+ /* forwarding pointer. */
+ lispobj first_word;
+
+ first_word = *((lispobj *)PTR(object));
+ if (Pointerp(first_word) && new_space_p(first_word)) {
+ /* Yep, there be a forwarding pointer. */
+ *start = first_word;
+ words_scavenged = 1;
+ }
+ else {
+ /* Scavenge that pointer. */
+ words_scavenged = (scavtab[type])(start, object);
+ }
+ }
+ else {
+ /* It points somewhere other than oldspace. Leave */
+ /* it alone. */
+ words_scavenged = 1;
+ }
+ }
+ else if(nwords==1) {
+ /* there are some situations where an
+ other-immediate may end up in a descriptor
+ register. I'm not sure whether this is
+ supposed to happen, but if it does then we
+ don't want to (a) barf or (b) scavenge over the
+ data-block, because there isn't one. So, if
+ we're checking a single word and it's anything
+ other than a pointer, just hush it up */
+
+ words_scavenged=1;
+ if((scavtab[type]==scav_lose) ||
+ (((scavtab[type])(start,object))>1)) {
+ fprintf(stderr,"warning: attempted to scavenge non-descriptor value %x at %p. If you can\nreproduce this warning, send a test case to sbcl-devel@lists.sourceforge.net\n",
+ object,start);
+ }
+ }
+ else if ((object & 3) == 0) {
+ /* It's a fixnum. Real easy. */
+ words_scavenged = 1;
+ }
+ else {
+ /* It's some random header object. */
+ words_scavenged = (scavtab[type])(start, object);
+
+ }
+#endif
+ start += words_scavenged;
+ nwords -= words_scavenged;
+ }
+ gc_assert(nwords == 0);
+}
+
+static void scavenge_newspace(void)
+{
+ lispobj *here, *next;
+
+ here = new_space;
+ while (here < new_space_free_pointer) {
+ /* printf("here=%lx, new_space_free_pointer=%lx\n",
+ here,new_space_free_pointer); */
+ next = new_space_free_pointer;
+ scavenge(here, next - here);
+ here = next;
+ }
+ /* printf("done with newspace\n"); */
+}
+
+\f
+/* Scavenging Interrupt Contexts */
+
+static int boxed_registers[] = BOXED_REGISTERS;
+
+static void scavenge_interrupt_context(os_context_t *context)
+{
+ int i;
+#ifdef reg_LIP
+ unsigned long lip;
+ unsigned long lip_offset;
+ int lip_register_pair;
+#endif
+ unsigned long pc_code_offset;
+#ifdef SC_NPC
+ unsigned long npc_code_offset;
+#endif
+
+ /* Find the LIP's register pair and calculate its offset */
+ /* before we scavenge the context. */
+#ifdef reg_LIP
+ lip = *os_context_register_addr(context, reg_LIP);
+ /* 0x7FFFFFFF or 0x7FFFFFFFFFFFFFFF ? */
+ lip_offset = 0x7FFFFFFF;
+ lip_register_pair = -1;
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ unsigned long reg;
+ long offset;
+ int index;
+
+ index = boxed_registers[i];
+ reg = *os_context_register_addr(context, index);
+ /* would be using PTR if not for integer length issues */
+ if ((reg & ~((1L<<lowtag_Bits)-1)) <= lip) {
+ offset = lip - reg;
+ if (offset < lip_offset) {
+ lip_offset = offset;
+ lip_register_pair = index;
+ }
+ }
+ }
+#endif reg_LIP
+
+ /* Compute the PC's offset from the start of the CODE */
+ /* register. */
+ pc_code_offset = *os_context_pc_addr(context) -
+ *os_context_register_addr(context, reg_CODE);
+#ifdef SC_NPC
+ npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
+#endif SC_NPC
+
+ /* Scanvenge all boxed registers in the context. */
+ for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+ int index;
+ lispobj foo;
+
+ index = boxed_registers[i];
+ foo = *os_context_register_addr(context,index);
+ scavenge((lispobj *) &foo, 1);
+ *os_context_register_addr(context,index) = foo;
+
+ /* this is unlikely to work as intended on bigendian
+ * 64 bit platforms */
+
+ scavenge((lispobj *)
+ os_context_register_addr(context, index), 1);
+ }
+
+#ifdef reg_LIP
+ /* Fix the LIP */
+ *os_context_register_addr(context, reg_LIP) =
+ *os_context_register_addr(context, lip_register_pair) + lip_offset;
+#endif reg_LIP
+
+ /* Fix the PC if it was in from space */
+ if (from_space_p(*os_context_pc_addr(context)))
+ *os_context_pc_addr(context) =
+ *os_context_register_addr(context, reg_CODE) + pc_code_offset;
+#ifdef SC_NPC
+ if (from_space_p(SC_NPC(context)))
+ SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
+#endif SC_NPC
+}
+
+void scavenge_interrupt_contexts(void)
+{
+ int i, index;
+ os_context_t *context;
+
+ index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
+ printf("Number of active contexts: %d\n", index);
+
+ for (i = 0; i < index; i++) {
+ context = lisp_interrupt_contexts[i];
+ scavenge_interrupt_context(context);
+ }
+}
+
+\f
+/* Debugging Code */
+
+void print_garbage(lispobj *from_space, lispobj *from_space_free_pointer)
+{
+ lispobj *start;
+ int total_words_not_copied;
+
+ printf("Scanning from space ...\n");
+
+ total_words_not_copied = 0;
+ start = from_space;
+ while (start < from_space_free_pointer) {
+ lispobj object;
+ int forwardp, type, nwords;
+ lispobj header;
+
+ object = *start;
+ forwardp = Pointerp(object) && new_space_p(object);
+
+ if (forwardp) {
+ int tag;
+ lispobj *pointer;
+
+ tag = LowtagOf(object);
+
+ switch (tag) {
+ case type_ListPointer:
+ nwords = 2;
+ break;
+ case type_InstancePointer:
+ printf("Don't know about instances yet!\n");
+ nwords = 1;
+ break;
+ case type_FunctionPointer:
+ nwords = 1;
+ break;
+ case type_OtherPointer:
+ pointer = (lispobj *) PTR(object);
+ header = *pointer;
+ type = TypeOf(header);
+ nwords = (sizetab[type])(pointer);
+ }
+ } else {
+ type = TypeOf(object);
+ nwords = (sizetab[type])(start);
+ total_words_not_copied += nwords;
+ printf("%4d words not copied at 0x%16lx; ",
+ nwords, (unsigned long) start);
+ printf("Header word is 0x%08x\n",
+ (unsigned int) object);
+ }
+ start += nwords;
+ }
+ printf("%d total words not copied.\n", total_words_not_copied);
+}
+
+\f
+/* Code and Code-Related Objects */
+
+#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+
+static lispobj trans_function_header(lispobj object);
+static lispobj trans_boxed(lispobj object);
+
+#if DIRECT_SCAV
+static int
+scav_function_pointer(lispobj *where, lispobj object)
+{
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* object is a pointer into from space. check to see */
+ /* if it has been forwarded */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (!(Pointerp(first) && new_space_p(first))) {
+ int type;
+ lispobj copy;
+
+ /* must transport object -- object may point */
+ /* to either a function header, a closure */
+ /* function header, or to a closure header. */
+
+ type = TypeOf(first);
+ switch (type) {
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ copy = trans_function_header(object);
+ break;
+ default:
+ copy = trans_boxed(object);
+ break;
+ }
+
+ first = *first_pointer = copy;
+ }
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_function_pointer(lispobj *where, lispobj object)
+{
+ lispobj *first_pointer;
+ lispobj copy;
+ lispobj first;
+ int type;
+
+ gc_assert(Pointerp(object));
+
+ /* object is a pointer into from space. Not a FP */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ /* must transport object -- object may point */
+ /* to either a function header, a closure */
+ /* function header, or to a closure header. */
+
+ type = TypeOf(first);
+ switch (type) {
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ copy = trans_function_header(object);
+ break;
+ default:
+ copy = trans_boxed(object);
+ break;
+ }
+
+ first = *first_pointer = copy;
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ return 1;
+}
+#endif
+
+static struct code *
+trans_code(struct code *code)
+{
+ struct code *new_code;
+ lispobj first, l_code, l_new_code;
+ int nheader_words, ncode_words, nwords;
+ unsigned long displacement;
+ lispobj fheaderl, *prev_pointer;
+
+#if defined(DEBUG_CODE_GC)
+ printf("\nTransporting code object located at 0x%08x.\n",
+ (unsigned long) code);
+#endif
+
+ /* if object has already been transported, just return pointer */
+ first = code->header;
+ if (Pointerp(first) && new_space_p(first)) {
+#ifdef DEBUG_CODE_GC
+ printf("Was already transported\n");
+#endif
+ return (struct code *) PTR(first);
+ }
+
+ gc_assert(TypeOf(first) == type_CodeHeader);
+
+ /* prepare to transport the code vector */
+ l_code = (lispobj) LOW_WORD(code) | type_OtherPointer;
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(code->header);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+ l_new_code = copy_object(l_code, nwords);
+ new_code = (struct code *) PTR(l_new_code);
+
+ displacement = l_new_code - l_code;
+
+#if defined(DEBUG_CODE_GC)
+ printf("Old code object at 0x%08x, new code object at 0x%08x.\n",
+ (unsigned long) code, (unsigned long) new_code);
+ printf("Code object is %d words long.\n", nwords);
+#endif
+
+ /* set forwarding pointer */
+ code->header = l_new_code;
+
+ /* set forwarding pointers for all the function headers in the */
+ /* code object. also fix all self pointers */
+
+ fheaderl = code->entry_points;
+ prev_pointer = &new_code->entry_points;
+
+ while (fheaderl != NIL) {
+ struct function *fheaderp, *nfheaderp;
+ lispobj nfheaderl;
+
+ fheaderp = (struct function *) PTR(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+
+ /* calcuate the new function pointer and the new */
+ /* function header */
+ nfheaderl = fheaderl + displacement;
+ nfheaderp = (struct function *) PTR(nfheaderl);
+
+ /* set forwarding pointer */
+#ifdef DEBUG_CODE_GC
+ printf("fheaderp->header (at %x) <- %x\n",
+ &(fheaderp->header) , nfheaderl);
+#endif
+ fheaderp->header = nfheaderl;
+
+ /* fix self pointer */
+ nfheaderp->self = nfheaderl;
+
+ *prev_pointer = nfheaderl;
+
+ fheaderl = fheaderp->next;
+ prev_pointer = &nfheaderp->next;
+ }
+
+#ifndef MACH
+ os_flush_icache((os_vm_address_t) (((int *)new_code) + nheader_words),
+ ncode_words * sizeof(int));
+#endif
+ return new_code;
+}
+
+static int
+scav_code_header(lispobj *where, lispobj object)
+{
+ struct code *code;
+ int nheader_words, ncode_words, nwords;
+ lispobj fheaderl;
+ struct function *fheaderp;
+
+ code = (struct code *) where;
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(object);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+#if defined(DEBUG_CODE_GC)
+ printf("\nScavening code object at 0x%08x.\n",
+ (unsigned long) where);
+ printf("Code object is %d words long.\n", nwords);
+ printf("Scavenging boxed section of code data block (%d words).\n",
+ nheader_words - 1);
+#endif
+
+ /* Scavenge the boxed section of the code data block */
+ scavenge(where + 1, nheader_words - 1);
+
+ /* Scavenge the boxed section of each function object in the */
+ /* code data block */
+ fheaderl = code->entry_points;
+ while (fheaderl != NIL) {
+ fheaderp = (struct function *) PTR(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+
+#if defined(DEBUG_CODE_GC)
+ printf("Scavenging boxed section of entry point located at 0x%08x.\n",
+ (unsigned long) PTR(fheaderl));
+#endif
+ scavenge(&fheaderp->name, 1);
+ scavenge(&fheaderp->arglist, 1);
+ scavenge(&fheaderp->type, 1);
+
+ fheaderl = fheaderp->next;
+ }
+
+ return nwords;
+}
+
+static lispobj
+trans_code_header(lispobj object)
+{
+ struct code *ncode;
+
+ ncode = trans_code((struct code *) PTR(object));
+ return (lispobj) LOW_WORD(ncode) | type_OtherPointer;
+}
+
+static int
+size_code_header(lispobj *where)
+{
+ struct code *code;
+ int nheader_words, ncode_words, nwords;
+
+ code = (struct code *) where;
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(code->header);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_return_pc_header(lispobj *where, lispobj object)
+{
+ fprintf(stderr, "GC lossage. Should not be scavenging a ");
+ fprintf(stderr, "Return PC Header.\n");
+ fprintf(stderr, "where = 0x%p, object = 0x%x", where, object);
+ lose(NULL);
+ return 0;
+}
+
+static lispobj
+trans_return_pc_header(lispobj object)
+{
+ struct function *return_pc;
+ unsigned long offset;
+ struct code *code, *ncode;
+ lispobj ret;
+ return_pc = (struct function *) PTR(object);
+ offset = HeaderValue(return_pc->header) * 4 ;
+
+ /* Transport the whole code object */
+ code = (struct code *) ((unsigned long) return_pc - offset);
+#ifdef DEBUG_CODE_GC
+ printf("trans_return_pc_header object=%x, code=%lx\n",object,code);
+#endif
+ ncode = trans_code(code);
+ if(object==0x304748d7) {
+ /* ldb_monitor(); */
+ }
+ ret= ((lispobj) LOW_WORD(ncode) + offset) | type_OtherPointer;
+#ifdef DEBUG_CODE_GC
+ printf("trans_return_pc_header returning %x\n",ret);
+#endif
+ return ret;
+}
+
+/* On the 386, closures hold a pointer to the raw address instead of the
+ function object, so we can use CALL [$FDEFN+const] to invoke the function
+ without loading it into a register. Given that code objects don't move,
+ we don't need to update anything, but we do have to figure out that the
+ function is still live. */
+#ifdef i386
+static
+scav_closure_header(where, object)
+lispobj *where, object;
+{
+ struct closure *closure;
+ lispobj fun;
+
+ closure = (struct closure *)where;
+ fun = closure->function - RAW_ADDR_OFFSET;
+ scavenge(&fun, 1);
+
+ return 2;
+}
+#endif
+
+static int
+scav_function_header(lispobj *where, lispobj object)
+{
+ fprintf(stderr, "GC lossage. Should not be scavenging a ");
+ fprintf(stderr, "Function Header.\n");
+ fprintf(stderr, "where = 0x%p, object = 0x%08x",
+ where, (unsigned int) object);
+ lose(NULL);
+ return 0;
+}
+
+static lispobj
+trans_function_header(lispobj object)
+{
+ struct function *fheader;
+ unsigned long offset;
+ struct code *code, *ncode;
+
+ fheader = (struct function *) PTR(object);
+ offset = HeaderValue(fheader->header) * 4;
+
+ /* Transport the whole code object */
+ code = (struct code *) ((unsigned long) fheader - offset);
+ ncode = trans_code(code);
+
+ return ((lispobj) LOW_WORD(ncode) + offset) | type_FunctionPointer;
+}
+
+
+\f
+/* Instances */
+
+#if DIRECT_SCAV
+static int
+scav_instance_pointer(lispobj *where, lispobj object)
+{
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* object is a pointer into from space. check to see */
+ /* if it has been forwarded */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (!(Pointerp(first) && new_space_p(first)))
+ first = *first_pointer = trans_boxed(object);
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_instance_pointer(lispobj *where, lispobj object)
+{
+ lispobj *first_pointer;
+
+ /* object is a pointer into from space. Not a FP */
+ first_pointer = (lispobj *) PTR(object);
+
+ *where = *first_pointer = trans_boxed(object);
+ return 1;
+}
+#endif
+
+\f
+/* Lists and Conses */
+
+static lispobj trans_list(lispobj object);
+
+#if DIRECT_SCAV
+static int
+scav_list_pointer(lispobj *where, lispobj object)
+{
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* object is a pointer into from space. check to see */
+ /* if it has been forwarded */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (!(Pointerp(first) && new_space_p(first)))
+ first = *first_pointer = trans_list(object);
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_list_pointer(lispobj *where, lispobj object)
+{
+ lispobj first, *first_pointer;
+
+ gc_assert(Pointerp(object));
+
+ /* object is a pointer into from space. Not a FP. */
+ first_pointer = (lispobj *) PTR(object);
+
+ first = *first_pointer = trans_list(object);
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ return 1;
+}
+#endif
+
+static lispobj
+trans_list(lispobj object)
+{
+ lispobj new_list_pointer;
+ struct cons *cons, *new_cons;
+
+ cons = (struct cons *) PTR(object);
+
+ /* ### Don't use copy_object here. */
+ new_list_pointer = copy_object(object, 2);
+ new_cons = (struct cons *) PTR(new_list_pointer);
+
+ /* Set forwarding pointer. */
+ cons->car = new_list_pointer;
+
+ /* Try to linearize the list in the cdr direction to help reduce */
+ /* paging. */
+
+ while (1) {
+ lispobj cdr, new_cdr, first;
+ struct cons *cdr_cons, *new_cdr_cons;
+
+ cdr = cons->cdr;
+
+ if (LowtagOf(cdr) != type_ListPointer ||
+ !from_space_p(cdr) ||
+ (Pointerp(first = *(lispobj *)PTR(cdr)) &&
+ new_space_p(first)))
+ break;
+
+ cdr_cons = (struct cons *) PTR(cdr);
+
+ /* ### Don't use copy_object here */
+ new_cdr = copy_object(cdr, 2);
+ new_cdr_cons = (struct cons *) PTR(new_cdr);
+
+ /* Set forwarding pointer */
+ cdr_cons->car = new_cdr;
+
+ /* Update the cdr of the last cons copied into new */
+ /* space to keep the newspace scavenge from having to */
+ /* do it. */
+ new_cons->cdr = new_cdr;
+
+ cons = cdr_cons;
+ new_cons = new_cdr_cons;
+ }
+
+ return new_list_pointer;
+}
+
+\f
+/* Scavenging and Transporting Other Pointers */
+
+#if DIRECT_SCAV
+static int
+scav_other_pointer(lispobj *where, lispobj object)
+{
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* object is a pointer into from space. check to see */
+ /* if it has been forwarded */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (!(Pointerp(first) && new_space_p(first)))
+ first = *first_pointer =
+ (transother[TypeOf(first)])(object);
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_other_pointer(lispobj *where, lispobj object)
+{
+ lispobj first, *first_pointer;
+
+ gc_assert(Pointerp(object));
+
+ /* Object is a pointer into from space - not a FP */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer = (transother[TypeOf(*first_pointer)])(object);
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ return 1;
+}
+#endif
+
+\f
+/* Immediate, Boxed, and Unboxed Objects */
+
+static int
+size_pointer(lispobj *where)
+{
+ return 1;
+}
+
+static int
+scav_immediate(lispobj *where, lispobj object)
+{
+ return 1;
+}
+
+static lispobj
+trans_immediate(lispobj object)
+{
+ fprintf(stderr, "GC lossage. Trying to transport an immediate!?\n");
+ lose(NULL);
+ return NIL;
+}
+
+static int
+size_immediate(lispobj *where)
+{
+ return 1;
+}
+
+
+static int
+scav_boxed(lispobj *where, lispobj object)
+{
+ return 1;
+}
+
+static lispobj
+trans_boxed(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_object(object, length);
+}
+
+static int
+size_boxed(lispobj *where)
+{
+ lispobj header;
+ unsigned long length;
+
+ header = *where;
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+
+/* Note: on the sparc we don't have to do anything special for fdefns, */
+/* cause the raw-addr has a function lowtag. */
+#ifndef sparc
+static int
+scav_fdefn(lispobj *where, lispobj object)
+{
+ struct fdefn *fdefn;
+
+ fdefn = (struct fdefn *)where;
+
+ if ((char *)(fdefn->function + RAW_ADDR_OFFSET)
+ == (char *)((unsigned long)(fdefn->raw_addr))) {
+ scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
+ fdefn->raw_addr = (u32) ((char *) LOW_WORD(fdefn->function)) + RAW_ADDR_OFFSET;
+ return sizeof(struct fdefn) / sizeof(lispobj);
+ }
+ else
+ return 1;
+}
+#endif
+
+static int
+scav_unboxed(lispobj *where, lispobj object)
+{
+ unsigned long length;
+
+ length = HeaderValue(object) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+
+static lispobj
+trans_unboxed(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_object(object, length);
+}
+
+static int
+size_unboxed(lispobj *where)
+{
+ lispobj header;
+ unsigned long length;
+
+ header = *where;
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+
+\f
+/* Vector-Like Objects */
+
+#define NWORDS(x,y) (CEILING((x),(y)) / (y))
+
+static int
+scav_string(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ /* NOTE: Strings contain one more byte of data than the length */
+ /* slot indicates. */
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_string(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ /* NOTE: Strings contain one more byte of data than the length */
+ /* slot indicates. */
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_string(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ /* NOTE: Strings contain one more byte of data than the length */
+ /* slot indicates. */
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+static int
+scav_vector(lispobj *where, lispobj object)
+{
+ if (HeaderValue(object) == subtype_VectorValidHashing)
+ *where = (subtype_VectorMustRehash<<type_Bits) | type_SimpleVector;
+
+ return 1;
+}
+
+
+static lispobj
+trans_vector(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_bit(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_bit(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_bit(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_2(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_2(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_4(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_4(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_8(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_8(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_16(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_16(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_32(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_32(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_single_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_single_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_single_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_double_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_double_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_double_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+
+#ifdef type_SimpleArrayLongFloat
+static int
+scav_vector_long_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_long_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_long_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 4 + 2, 2);
+#endif
+
+ return nwords;
+}
+#endif
+
+
+#ifdef type_SimpleArrayComplexSingleFloat
+static int
+scav_vector_complex_single_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_single_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_complex_single_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+#ifdef type_SimpleArrayComplexDoubleFloat
+static int
+scav_vector_complex_double_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_double_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_complex_double_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+#ifdef type_SimpleArrayComplexLongFloat
+static int
+scav_vector_complex_long_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_long_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+ return copy_object(object, nwords);
+}
+
+static int
+size_vector_complex_long_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+#ifdef sparc
+ nwords = CEILING(length * 8 + 2, 2);
+#endif
+
+ return nwords;
+}
+#endif
+
+\f
+/* Weak Pointers */
+
+#define WEAK_POINTER_NWORDS \
+ CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
+
+static int
+scav_weak_pointer(lispobj *where, lispobj object)
+{
+ /* Do not let GC scavenge the value slot of the weak pointer */
+ /* (that is why it is a weak pointer). Note: we could use */
+ /* the scav_unboxed method here. */
+
+ return WEAK_POINTER_NWORDS;
+}
+
+static lispobj
+trans_weak_pointer(lispobj object)
+{
+ lispobj copy;
+ struct weak_pointer *wp;
+
+ gc_assert(Pointerp(object));
+
+#if defined(DEBUG_WEAK)
+ printf("Transporting weak pointer from 0x%08x\n", object);
+#endif
+
+ /* Need to remember where all the weak pointers are that have */
+ /* been transported so they can be fixed up in a post-GC pass. */
+
+ copy = copy_object(object, WEAK_POINTER_NWORDS);
+ wp = (struct weak_pointer *) PTR(copy);
+
+
+ /* Push the weak pointer onto the list of weak pointers. */
+ wp->next = LOW_WORD(weak_pointers);
+ weak_pointers = wp;
+
+ return copy;
+}
+
+static int
+size_weak_pointer(lispobj *where)
+{
+ return WEAK_POINTER_NWORDS;
+}
+
+void scan_weak_pointers(void)
+{
+ struct weak_pointer *wp;
+
+ for (wp = weak_pointers; wp != (struct weak_pointer *) NULL;
+ wp = (struct weak_pointer *)((unsigned long)wp->next)) {
+ lispobj value;
+ lispobj first, *first_pointer;
+
+ value = wp->value;
+
+#if defined(DEBUG_WEAK)
+ printf("Weak pointer at 0x%p\n", wp);
+ printf("Value: 0x%08x\n", (unsigned int) value);
+#endif
+
+ if (!(Pointerp(value) && from_space_p(value)))
+ continue;
+
+ /* Now, we need to check if the object has been */
+ /* forwarded. If it has been, the weak pointer is */
+ /* still good and needs to be updated. Otherwise, the */
+ /* weak pointer needs to be nil'ed out. */
+
+ first_pointer = (lispobj *) PTR(value);
+ first = *first_pointer;
+
+#if defined(DEBUG_WEAK)
+ printf("First: 0x%08x\n", (unsigned long) first);
+#endif
+
+ if (Pointerp(first) && new_space_p(first))
+ wp->value = first;
+ else {
+ wp->value = NIL;
+ wp->broken = T;
+ }
+ }
+}
+
+
+\f
+/* Initialization */
+
+static int
+scav_lose(lispobj *where, lispobj object)
+{
+ fprintf(stderr, "GC lossage. No scavenge function for object 0x%08x (at 0x%016lx)\n",
+ (unsigned int) object, (unsigned long)where);
+ lose(NULL);
+ return 0;
+}
+
+static lispobj
+trans_lose(lispobj object)
+{
+ fprintf(stderr, "GC lossage. No transport function for object 0x%08x\n",
+ (unsigned int)object);
+ lose(NULL);
+ return NIL;
+}
+
+static int
+size_lose(lispobj *where)
+{
+ fprintf(stderr, "Size lossage. No size function for object at 0x%p\n",
+ where);
+ fprintf(stderr, "First word of object: 0x%08x\n",
+ (u32) *where);
+ return 1;
+}
+
+void gc_init(void)
+{
+ int i;
+
+ /* Scavenge Table */
+ for (i = 0; i < 256; i++)
+ scavtab[i] = scav_lose;
+ /* scavtab[i] = scav_immediate; */
+
+ for (i = 0; i < 32; i++) {
+ scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
+ scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
+ /* OtherImmediate0 */
+ scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
+ scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
+ scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
+ /* OtherImmediate1 */
+ scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
+ }
+
+ scavtab[type_Bignum] = scav_unboxed;
+ scavtab[type_Ratio] = scav_boxed;
+ scavtab[type_SingleFloat] = scav_unboxed;
+ scavtab[type_DoubleFloat] = scav_unboxed;
+#ifdef type_LongFloat
+ scavtab[type_LongFloat] = scav_unboxed;
+#endif
+ scavtab[type_Complex] = scav_boxed;
+#ifdef type_ComplexSingleFloat
+ scavtab[type_ComplexSingleFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ scavtab[type_ComplexDoubleFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ scavtab[type_ComplexLongFloat] = scav_unboxed;
+#endif
+ scavtab[type_SimpleArray] = scav_boxed;
+ scavtab[type_SimpleString] = scav_string;
+ scavtab[type_SimpleBitVector] = scav_vector_bit;
+ scavtab[type_SimpleVector] = scav_vector;
+ scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
+ scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
+ scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
+ scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
+ scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
+#endif
+ scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
+ scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
+#endif
+ scavtab[type_ComplexString] = scav_boxed;
+ scavtab[type_ComplexBitVector] = scav_boxed;
+ scavtab[type_ComplexVector] = scav_boxed;
+ scavtab[type_ComplexArray] = scav_boxed;
+ scavtab[type_CodeHeader] = scav_code_header;
+ scavtab[type_FunctionHeader] = scav_function_header;
+ scavtab[type_ClosureFunctionHeader] = scav_function_header;
+ scavtab[type_ReturnPcHeader] = scav_return_pc_header;
+#ifdef i386
+ scavtab[type_ClosureHeader] = scav_closure_header;
+ scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
+ scavtab[type_ByteCodeFunction] = scav_closure_header;
+ scavtab[type_ByteCodeClosure] = scav_closure_header;
+ /* scavtab[type_DylanFunctionHeader] = scav_closure_header; */
+#else
+ scavtab[type_ClosureHeader] = scav_boxed;
+ scavtab[type_FuncallableInstanceHeader] = scav_boxed;
+ scavtab[type_ByteCodeFunction] = scav_boxed;
+ scavtab[type_ByteCodeClosure] = scav_boxed;
+ /* scavtab[type_DylanFunctionHeader] = scav_boxed; */
+#endif
+ scavtab[type_ValueCellHeader] = scav_boxed;
+ scavtab[type_SymbolHeader] = scav_boxed;
+ scavtab[type_BaseChar] = scav_immediate;
+ scavtab[type_Sap] = scav_unboxed;
+ scavtab[type_UnboundMarker] = scav_immediate;
+ scavtab[type_WeakPointer] = scav_weak_pointer;
+ scavtab[type_InstanceHeader] = scav_boxed;
+#ifndef sparc
+ scavtab[type_Fdefn] = scav_fdefn;
+#else
+ scavtab[type_Fdefn] = scav_boxed;
+#endif
+
+ /* Transport Other Table */
+ for (i = 0; i < 256; i++)
+ transother[i] = trans_lose;
+
+ transother[type_Bignum] = trans_unboxed;
+ transother[type_Ratio] = trans_boxed;
+ transother[type_SingleFloat] = trans_unboxed;
+ transother[type_DoubleFloat] = trans_unboxed;
+#ifdef type_LongFloat
+ transother[type_LongFloat] = trans_unboxed;
+#endif
+ transother[type_Complex] = trans_boxed;
+#ifdef type_ComplexSingleFloat
+ transother[type_ComplexSingleFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ transother[type_ComplexDoubleFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ transother[type_ComplexLongFloat] = trans_unboxed;
+#endif
+ transother[type_SimpleArray] = trans_boxed;
+ transother[type_SimpleString] = trans_string;
+ transother[type_SimpleBitVector] = trans_vector_bit;
+ transother[type_SimpleVector] = trans_vector;
+ transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
+ transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
+ transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
+ transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
+ transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
+#endif
+ transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
+ transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
+#endif
+ transother[type_ComplexString] = trans_boxed;
+ transother[type_ComplexBitVector] = trans_boxed;
+ transother[type_ComplexVector] = trans_boxed;
+ transother[type_ComplexArray] = trans_boxed;
+ transother[type_CodeHeader] = trans_code_header;
+ transother[type_FunctionHeader] = trans_function_header;
+ transother[type_ClosureFunctionHeader] = trans_function_header;
+ transother[type_ReturnPcHeader] = trans_return_pc_header;
+ transother[type_ClosureHeader] = trans_boxed;
+ transother[type_FuncallableInstanceHeader] = trans_boxed;
+ transother[type_ByteCodeFunction] = trans_boxed;
+ transother[type_ByteCodeClosure] = trans_boxed;
+ transother[type_ValueCellHeader] = trans_boxed;
+ transother[type_SymbolHeader] = trans_boxed;
+ transother[type_BaseChar] = trans_immediate;
+ transother[type_Sap] = trans_unboxed;
+ transother[type_UnboundMarker] = trans_immediate;
+ transother[type_WeakPointer] = trans_weak_pointer;
+ transother[type_InstanceHeader] = trans_boxed;
+ transother[type_Fdefn] = trans_boxed;
+
+ /* Size table */
+
+ for (i = 0; i < 256; i++)
+ sizetab[i] = size_lose;
+
+ for (i = 0; i < 32; i++) {
+ sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
+ sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
+ /* OtherImmediate0 */
+ sizetab[type_ListPointer|(i<<3)] = size_pointer;
+ sizetab[type_OddFixnum|(i<<3)] = size_immediate;
+ sizetab[type_InstancePointer|(i<<3)] = size_pointer;
+ /* OtherImmediate1 */
+ sizetab[type_OtherPointer|(i<<3)] = size_pointer;
+ }
+
+ sizetab[type_Bignum] = size_unboxed;
+ sizetab[type_Ratio] = size_boxed;
+ sizetab[type_SingleFloat] = size_unboxed;
+ sizetab[type_DoubleFloat] = size_unboxed;
+#ifdef type_LongFloat
+ sizetab[type_LongFloat] = size_unboxed;
+#endif
+ sizetab[type_Complex] = size_boxed;
+#ifdef type_ComplexSingleFloat
+ sizetab[type_ComplexSingleFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ sizetab[type_ComplexDoubleFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ sizetab[type_ComplexLongFloat] = size_unboxed;
+#endif
+ sizetab[type_SimpleArray] = size_boxed;
+ sizetab[type_SimpleString] = size_string;
+ sizetab[type_SimpleBitVector] = size_vector_bit;
+ sizetab[type_SimpleVector] = size_vector;
+ sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
+ sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
+ sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
+ sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
+ sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
+#endif
+ sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
+ sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
+#endif
+ sizetab[type_ComplexString] = size_boxed;
+ sizetab[type_ComplexBitVector] = size_boxed;
+ sizetab[type_ComplexVector] = size_boxed;
+ sizetab[type_ComplexArray] = size_boxed;
+ sizetab[type_CodeHeader] = size_code_header;
+#if 0
+ /* Shouldn't see these so just lose if it happens */
+ sizetab[type_FunctionHeader] = size_function_header;
+ sizetab[type_ClosureFunctionHeader] = size_function_header;
+ sizetab[type_ReturnPcHeader] = size_return_pc_header;
+#endif
+ sizetab[type_ClosureHeader] = size_boxed;
+ sizetab[type_FuncallableInstanceHeader] = size_boxed;
+ sizetab[type_ValueCellHeader] = size_boxed;
+ sizetab[type_SymbolHeader] = size_boxed;
+ sizetab[type_BaseChar] = size_immediate;
+ sizetab[type_Sap] = size_unboxed;
+ sizetab[type_UnboundMarker] = size_immediate;
+ sizetab[type_WeakPointer] = size_weak_pointer;
+ sizetab[type_InstanceHeader] = size_boxed;
+ sizetab[type_Fdefn] = size_boxed;
+}
+
+
+\f
+/* Noise to manipulate the gc trigger stuff. */
+
+#ifndef ibmrt
+
+void set_auto_gc_trigger(os_vm_size_t dynamic_usage)
+{
+ os_vm_address_t addr=(os_vm_address_t)current_dynamic_space +
+ dynamic_usage;
+ long length =
+ DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
+
+ if(addr < (os_vm_address_t)dynamic_space_free_pointer) {
+ fprintf(stderr,
+ "set_auto_gc_trigger: tried to set gc trigger too low! (%d < %p)\n",
+ (unsigned int)dynamic_usage,
+ (os_vm_address_t)dynamic_space_free_pointer
+ - (os_vm_address_t)current_dynamic_space);
+ return;
+ }
+ else if (length < 0) {
+ fprintf(stderr,
+ "set_auto_gc_trigger: tried to set gc trigger too high! (%p)\n",
+ dynamic_usage);
+ return;
+ }
+
+ addr=os_round_up_to_page(addr);
+ length=os_trunc_size_to_page(length);
+
+#if defined(SUNOS) || defined(SOLARIS)
+ os_invalidate(addr,length);
+#else
+ os_protect(addr, length, 0);
+#endif
+
+ current_auto_gc_trigger = (lispobj *)addr;
+}
+
+void clear_auto_gc_trigger(void)
+{
+ if(current_auto_gc_trigger!=NULL){
+#if defined(SUNOS) || defined(SOLARIS)/* don't want to force whole space into swapping mode... */
+ os_vm_address_t addr=(os_vm_address_t)current_auto_gc_trigger;
+ os_vm_size_t length=
+ DYNAMIC_SPACE_SIZE + (os_vm_address_t)current_dynamic_space - addr;
+
+ os_validate(addr,length);
+#else
+ os_protect((os_vm_address_t)current_dynamic_space,
+ DYNAMIC_SPACE_SIZE,
+ OS_VM_PROT_ALL);
+#endif
+
+ current_auto_gc_trigger = NULL;
+ }
+}
+
+#endif
/* Should we unmap a page and re-mmap it to have it zero filled? */
#if defined(__FreeBSD__) || defined(__OpenBSD__)
-/* Note: this can waste a lot of swap on FreeBSD so don't unmap there.
+/* comment from cmucl-2.4.8: This can waste a lot of swap on FreeBSD
+ * so don't unmap there.
*
- * Presumably this behavior exists on OpenBSD too, so don't unmap
- * there either. -- WHN 20000727 */
+ * The CMU CL comment didn't specify a version, but was probably an
+ * old version of FreeBSD (pre-4.0), so this might no longer be true.
+ * OTOH, if it is true, this behavior might exist on OpenBSD too, so
+ * for now we don't unmap there either. -- WHN 2001-04-07 */
boolean gencgc_unmap_zero = 0;
#else
boolean gencgc_unmap_zero = 1;
#include "runtime.h"
#include "sbcl.h"
#include "globals.h"
+#include "validate.h"
int foreign_function_call_active;
lispobj *current_binding_stack_pointer;
#endif
+/* ALLOCATION_POINTER is more or less synonymous with RT, it seems.
+ * Anyone want to do an RT port of sbcl?
+ */
+
#ifndef ALLOCATION_POINTER
+/* The Object Formerly Known As current_dynamic_space_free_pointer */
lispobj *dynamic_space_free_pointer;
#endif
+
#ifndef INTERNAL_GC_TRIGGER
lispobj *current_auto_gc_trigger;
#endif
+/* for copying GCs, this points to the start of the dynamic space
+ * currently in use (that will become the from_space when the next GC
+ * is done). For the GENCGC, it always points to DYNAMIC_0_SPACE_START */
+lispobj *current_dynamic_space;
+
void globals_init(void)
{
/* Space, stack, and free pointer vars are initialized by
#endif
#if !defined(ibmrt) && !defined(__i386__)
+/* FIXME: why doesn't the x86 need this? */
extern lispobj *dynamic_space_free_pointer;
extern lispobj *current_auto_gc_trigger;
#endif
+extern lispobj *current_dynamic_space;
+
extern void globals_init(void);
#else LANGUAGE_ASSEMBLY
-/* These are needed by ./assem.s */
+/* These are needed by assem.S. */
#ifdef mips
#define EXTERN(name,bytes) .extern name bytes
#define EXTERN(name,bytes) .globl _/**/name
#endif
+#ifdef alpha
+#ifdef linux
+#define EXTERN(name,bytes) .globl name
+#endif
+#endif
+
+/* I'm very dubious about this. Linux hasn't used _ on external names
+ * since ELF became prevalent - i.e. about 1996, on x86 -dan 20010125 */
#ifdef __i386__
#ifdef __linux__
#define EXTERN(name,bytes) .globl _/**/name
EXTERN(current_control_stack_pointer, 4)
EXTERN(current_control_frame_pointer, 4)
-#if !defined(ibmrt) && !defined(__i386__)
EXTERN(current_binding_stack_pointer, 4)
EXTERN(dynamic_space_free_pointer, 4)
-#endif
+EXTERN(current_dynamic_space, 4)
#ifdef mips
EXTERN(current_flags_register, 4)
lispobj debug_print(lispobj string)
{
- fprintf(stderr, "%s\n", (char *)(((struct vector *)PTR(string))->data));
+ /* This is a kludge. It's not actually safe - in general - to use
+ %primitive print on the alpha, because it skips half of the
+ number stack setup that should usually be done on a function call,
+ so the called routine (i.e. this one) ends up being able to overwrite
+ local variables in the caller. Rather than fix this everywhere
+ that %primitive print is used (it's only a debugging aid anyway)
+ we just put guarantee our safety by putting an unused buffer on
+ the stack before doing anything else here */
+ char untouched[32];
+ fprintf(stderr, "%s\n",
+ (char *)(((struct vector *)PTR(string))->data),untouched);
return NIL;
}
* In that case, the Lisp-level handler is stored in interrupt_handlers[..]
* and interrupt_low_level_handlers[..] is cleared.
*
- * However, some signals need special handling, e.g. the SIGSEGV (for
- * Linux) or SIGBUS (for FreeBSD) used by the garbage collector to
- * detect violations of write protection, because some cases of such
- * signals (e.g. GC-related violations of write protection) are
- * handled at C level and never passed on to Lisp. For such signals,
- * we still store any Lisp-level handler in interrupt_handlers[..],
- * but for the outermost handle we use the value from
- * interrupt_low_level_handlers[..], instead of the ordinary
- * interrupt_handle_now(..) or interrupt_handle_later(..).
+ * However, some signals need special handling, e.g.
*
- * -- WHN 20000728 */
+ * o the SIGSEGV (for Linux) or SIGBUS (for FreeBSD) used by the
+ * garbage collector to detect violations of write protection,
+ * because some cases of such signals (e.g. GC-related violations of
+ * write protection) are handled at C level and never passed on to
+ * Lisp. For such signals, we still store any Lisp-level handler
+ * in interrupt_handlers[..], but for the outermost handle we use
+ * the value from interrupt_low_level_handlers[..], instead of the
+ * ordinary interrupt_handle_now(..) or interrupt_handle_later(..).
+ *
+ * o the SIGTRAP (Linux/Alpha) which Lisp code uses to handle breakpoints,
+ * pseudo-atomic sections, and some classes of error (e.g. "function
+ * not defined"). This never goes anywhere near the Lisp handlers at all.
+ * See runtime/alpha-arch.c and code/signal.lisp
+ *
+ * - WHN 20000728, dan 20010128 */
+
+
void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) = {0};
union interrupt_handler interrupt_handlers[NSIG];
if (internal_errors_enabled) {
SHOW("in interrupt_internal_error");
+#define QSHOW 1
#if QSHOW
/* Display some rudimentary debugging information about the
* error, so that even if the Lisp error handler gets badly
}
}
+/* This function handles pending interrupts. Note that in C/kernel
+ * terms we dealt with the signal already; we just haven't decided
+ * whether to call a Lisp handler or do a GC or something like that.
+ * If it helps, you can think of pending_{signal,mask,info} as a
+ * one-element queue of signals that we have acknowledged but not
+ * processed */
+
void
interrupt_handle_pending(os_context_t *context)
{
* (FIXME: Why? This is the way it was done in CMU CL, and it
* even had the comment noting that this is the way it was
* done, but no motivation..) */
- lispobj context_sap = alloc_sap(context);
- lispobj info_sap = alloc_sap(info);
-
+ lispobj info_sap,context_sap = alloc_sap(context);
+ info_sap = alloc_sap(info);
/* Allow signals again. */
sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
* SET_FPU_CONTROL_WORD(context->__fpregs_mem.cw);
* #endif */
+ /* see comments at top of code/signal.lisp for what's going on here
+ * with INTERRUPTS_ENABLED/INTERRUPT_HANDLE_NOW
+ */
if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
/* FIXME: This code is exactly the same as the code in the
os_context_sigmask_addr(context),
sizeof(sigset_t));
sigaddset_blockable(os_context_sigmask_addr(context));
-
SetSymbolValue(INTERRUPT_PENDING, T);
} else if (
context);
return (badaddr >= current_auto_gc_trigger &&
- badaddr < DYNAMIC_SPACE_START + DYNAMIC_SPACE_SIZE);
+ badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
}
}
#endif
#ifndef __i386__
+/* This function gets called from the SIGSEGV (Linux) or SIGBUS (BSD)
+ * handler. Here we check whether the signal was due to treading on
+ * the mprotect()ed zone - and if so, arrange for a GC to happen.
+ */
boolean
-interrupt_maybe_gc(int signal, siginfo_t *info, os_context_t *context)
+interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context)
{
+ os_context_t *context=(os_context_t *) void_context;
+
if (!foreign_function_call_active
#ifndef INTERNAL_GC_TRIGGER
&& gc_trigger_hit(signal, info, context)
#endif
if (arch_pseudo_atomic_atomic(context)) {
+ /* don't GC during an atomic operation. Instead, copy the
+ * signal mask somewhere safe. interrupt_handle_pending
+ * will detect pending_signal==0 and know to do a GC with the
+ * signal context instead of calling a Lisp-level handler */
maybe_gc_pending = 1;
if (pending_signal == 0) {
/* FIXME: This copy-pending_mask-then-sigaddset_blockable
--- /dev/null
+/* This script allegedly has the same effect as -taso would do on Digital
+ * Unix - that is, it forces stuff into the low 2Gb where 32-bit pointers
+ * can find it */
+
+OUTPUT_FORMAT("elf64-alpha", "elf64-alpha",
+ "elf64-alpha")
+OUTPUT_ARCH(alpha)
+ENTRY(__start)
+SEARCH_DIR(/lib); SEARCH_DIR(/usr/lib); SEARCH_DIR(/usr/local/lib); SEARCH_DIR(/usr/alpha-linux/lib);
+/* Do we need any of these for elf?
+ __DYNAMIC = 0; */
+SECTIONS
+{
+ /* Read-only sections, merged into text segment: */
+ . = 0x08048000 + SIZEOF_HEADERS;
+ .interp : { *(.interp) }
+ .hash : { *(.hash) }
+ .dynsym : { *(.dynsym) }
+ .dynstr : { *(.dynstr) }
+ .gnu.version : { *(.gnu.version) }
+ .gnu.version_d : { *(.gnu.version_d) }
+ .gnu.version_r : { *(.gnu.version_r) }
+ .rel.text :
+ { *(.rel.text) *(.rel.gnu.linkonce.t*) }
+ .rela.text :
+ { *(.rela.text) *(.rela.gnu.linkonce.t*) }
+ .rel.data :
+ { *(.rel.data) *(.rel.gnu.linkonce.d*) }
+ .rela.data :
+ { *(.rela.data) *(.rela.gnu.linkonce.d*) }
+ .rel.rodata :
+ { *(.rel.rodata) *(.rel.gnu.linkonce.r*) }
+ .rela.rodata :
+ { *(.rela.rodata) *(.rela.gnu.linkonce.r*) }
+ .rel.got : { *(.rel.got) }
+ .rela.got : { *(.rela.got) }
+ .rel.ctors : { *(.rel.ctors) }
+ .rela.ctors : { *(.rela.ctors) }
+ .rel.dtors : { *(.rel.dtors) }
+ .rela.dtors : { *(.rela.dtors) }
+ .rel.init : { *(.rel.init) }
+ .rela.init : { *(.rela.init) }
+ .rel.fini : { *(.rel.fini) }
+ .rela.fini : { *(.rela.fini) }
+ .rel.bss : { *(.rel.bss) }
+ .rela.bss : { *(.rela.bss) }
+ .rel.plt : { *(.rel.plt) }
+ .rela.plt : { *(.rela.plt) }
+ .init : { *(.init) } =0x47ff041f
+ .text :
+ {
+ *(.text)
+ *(.stub)
+ /* .gnu.warning sections are handled specially by elf32.em. */
+ *(.gnu.warning)
+ *(.gnu.linkonce.t*)
+ } =0x47ff041f
+ _etext = .;
+ PROVIDE (etext = .);
+ .fini : { *(.fini) } =0x47ff041f
+ .rodata : { *(.rodata) *(.gnu.linkonce.r*) }
+ .rodata1 : { *(.rodata1) }
+ .reginfo : { *(.reginfo) }
+ /* Adjust the address for the data segment. We want to adjust up to
+ the same address within the page on the next page up. */
+ . = ALIGN(0x100000) + (. & (0x100000 - 1));
+ .data :
+ {
+ *(.data)
+ *(.gnu.linkonce.d*)
+ CONSTRUCTORS
+ }
+ .data1 : { *(.data1) }
+ .ctors :
+ {
+ *(.ctors)
+ }
+ .dtors :
+ {
+ *(.dtors)
+ }
+ .plt : { *(.plt) }
+ .got : { *(.got.plt) *(.got) }
+ .dynamic : { *(.dynamic) }
+ /* We want the small data sections together, so single-instruction offsets
+ can access them all, and initialized data all before uninitialized, so
+ we can shorten the on-disk segment size. */
+ .sdata : { *(.sdata) }
+ _edata = .;
+ PROVIDE (edata = .);
+ __bss_start = .;
+ .sbss : { *(.sbss) *(.scommon) }
+ .bss :
+ {
+ *(.dynbss)
+ *(.bss)
+ *(COMMON)
+ }
+ . = ALIGN(64 / 8);
+ _end = . ;
+ PROVIDE (end = .);
+ /* Stabs debugging sections. */
+ .stab 0 : { *(.stab) }
+ .stabstr 0 : { *(.stabstr) }
+ .stab.excl 0 : { *(.stab.excl) }
+ .stab.exclstr 0 : { *(.stab.exclstr) }
+ .stab.index 0 : { *(.stab.index) }
+ .stab.indexstr 0 : { *(.stab.indexstr) }
+ .comment 0 : { *(.comment) }
+ /* DWARF debug sections.
+ Symbols in the DWARF debugging sections are relative to the beginning
+ of the section so we begin them at 0. */
+ /* DWARF 1 */
+ .debug 0 : { *(.debug) }
+ .line 0 : { *(.line) }
+ /* GNU DWARF 1 extensions */
+ .debug_srcinfo 0 : { *(.debug_srcinfo) }
+ .debug_sfnames 0 : { *(.debug_sfnames) }
+ /* DWARF 1.1 and DWARF 2 */
+ .debug_aranges 0 : { *(.debug_aranges) }
+ .debug_pubnames 0 : { *(.debug_pubnames) }
+ /* DWARF 2 */
+ .debug_info 0 : { *(.debug_info) }
+ .debug_abbrev 0 : { *(.debug_abbrev) }
+ .debug_line 0 : { *(.debug_line) }
+ .debug_frame 0 : { *(.debug_frame) }
+ .debug_str 0 : { *(.debug_str) }
+ .debug_loc 0 : { *(.debug_loc) }
+ .debug_macinfo 0 : { *(.debug_macinfo) }
+ /* SGI/MIPS DWARF 2 extensions */
+ .debug_weaknames 0 : { *(.debug_weaknames) }
+ .debug_funcnames 0 : { *(.debug_funcnames) }
+ .debug_typenames 0 : { *(.debug_typenames) }
+ .debug_varnames 0 : { *(.debug_varnames) }
+ /* These must appear regardless of . */
+}
+
/*
- * the Linux incarnation of OS-dependent routines
+ * the Linux incarnation of OS-dependent routines. See also
+ * $(sbcl_arch)-linux-os.c
*
* This file (along with os.h) exports an OS-independent interface to
* the operating system VM facilities. Surprise surprise, this
}
os_vm_page_size = getpagesize();
-
+ /* this could just as well be in arch_init, but it's not */
+#ifdef i386
SET_FPU_CONTROL_WORD(0x1372|4|8|16|32); /* no interrupts */
+#endif
}
-/* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
- * <sys/ucontext.h> file to define symbolic names for offsets into
- * gregs[], but it's conditional on __USE_GNU and not defined, so
- * we need to do this nasty absolute index magic number thing
- * instead. */
-int *
-os_context_register_addr(os_context_t *context, int offset)
-{
- switch(offset) {
- case 0: return &context->uc_mcontext.gregs[11]; /* EAX */
- case 2: return &context->uc_mcontext.gregs[10]; /* ECX */
- case 4: return &context->uc_mcontext.gregs[9]; /* EDX */
- case 6: return &context->uc_mcontext.gregs[8]; /* EBX */
- case 8: return &context->uc_mcontext.gregs[7]; /* ESP */
- case 10: return &context->uc_mcontext.gregs[6]; /* EBP */
- case 12: return &context->uc_mcontext.gregs[5]; /* ESI */
- case 14: return &context->uc_mcontext.gregs[4]; /* EDI */
- default: return 0;
- }
-}
-int *
-os_context_pc_addr(os_context_t *context)
-{
- return &context->uc_mcontext.gregs[14];
-}
-int *
-os_context_sp_addr(os_context_t *context)
-{
- return &context->uc_mcontext.gregs[17];
-}
-
-sigset_t *
-os_context_sigmask_addr(os_context_t *context)
-{
- return &context->uc_sigmask;
-}
+/* various os_context_*_addr accessors moved to {x86,alpha}-linux-os.c
+ * -dan 20010125
+ */
/* In Debian CMU CL ca. 2.4.9, it was possible to get an infinite
* cascade of errors from do_mmap(..). This variable is a counter to
}
void
-os_flush_icache(os_vm_address_t address, os_vm_size_t length)
-{
-}
-
-void
os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
{
if (mprotect(address, length, prot) == -1) {
static boolean
in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
{
- char* beg = (char*)sbeg;
- char* end = (char*)sbeg + slen;
+ char* beg = (char*)((long)sbeg);
+ char* end = (char*)((long)sbeg) + slen;
char* adr = (char*)a;
return (adr >= beg && adr < end);
}
* any OS-dependent special low-level handling for signals
*/
-#if !defined GENCGC
-
-void
-os_install_interrupt_handlers(void)
-{}
-
-#else
+#if defined GENCGC
/*
* The GENCGC needs to be hooked into whatever signal is raised for
interrupt_handle_now(signal, info, void_context);
}
}
+
+#else
+
+static void
+sigsegv_handler(int signal, siginfo_t *info, void* void_context)
+{
+ os_context_t *context = (os_context_t*)void_context;
+ os_vm_address_t addr;
+
+#ifdef i386
+ interrupt_handle_now(signal,contextstruct);
+#else
+#define CONTROL_STACK_TOP (((char*)CONTROL_STACK_START)+CONTROL_STACK_SIZE)
+
+ addr = arch_get_bad_addr(signal,info,context);
+
+ if(addr != NULL &&
+ *os_context_register_addr(context,reg_ALLOC) & (1L<<63)){
+ /* This is the end of a pseudo-atomic section during which
+ * a signal was received. We must deal with the pending interrupt
+ * (see also interrupt.c, ../code/interrupt.lisp)
+ */
+
+ /* (how we got here: when interrupting, we set bit 63 in
+ * reg_Alloc. At the end of the atomic section we tried to
+ * write to reg_Alloc, got a SIGSEGV (there's nothing mapped
+ * there) so ended up here
+ */
+ *os_context_register_addr(context,reg_ALLOC) -= (1L<<63);
+ interrupt_handle_pending(context);
+ } else if (addr > CONTROL_STACK_TOP && addr < BINDING_STACK_START) {
+ fprintf(stderr, "Possible stack overflow at 0x%016lX: CONTROL_STACK_TOP=%lx, BINDING_STACK_START=%lx\n",addr, CONTROL_STACK_TOP,BINDING_STACK_START);
+ /* try to fix control frame pointer */
+ while ( ! (CONTROL_STACK_START <= *current_control_frame_pointer &&
+ *current_control_frame_pointer <= CONTROL_STACK_TOP))
+ ((char*)current_control_frame_pointer) -= sizeof(lispobj);
+ ldb_monitor();
+ } else if (!interrupt_maybe_gc(signal, info, context)) {
+ interrupt_handle_now(signal, info, context);
+ }
+#endif
+}
+#endif
+
+
+
void
os_install_interrupt_handlers(void)
{
interrupt_install_low_level_handler(SIGSEGV, sigsegv_handler);
}
-#endif
#define OS_VM_PROT_WRITE PROT_WRITE
#define OS_VM_PROT_EXECUTE PROT_EXEC
-#define OS_VM_DEFAULT_PAGESIZE 4096
-
#define SET_FPU_CONTROL_WORD(cw) asm("fldcw %0" : : "m" (cw))
+
+/* /usr/include/asm/sigcontext.h */
+typedef long sigcontext_register_t ;
static cmd print_context_cmd;
static cmd backtrace_cmd, purify_cmd, catchers_cmd;
static cmd grab_sigs_cmd;
+static cmd kill_cmd;
static struct cmd {
char *cmd, *help;
{"catchers", "Print a list of all the active catchers.", catchers_cmd},
{"context", "Print interrupt context number I.", print_context_cmd},
{"dump", "Dump memory starting at ADDRESS for COUNT words.", dump_cmd},
- {"d", "dump", dump_cmd},
+ {"d", "Alias for dump", dump_cmd},
{"exit", "Exit this instance of the monitor.", exit_cmd},
{"flush", "Flush all temp variables.", flush_cmd},
/* (Classic CMU CL had a "gc" command here, which seems like a
* reasonable idea, but the code was stale (incompatible with
* gencgc) so I just flushed it. -- WHN 20000814 */
{"grab-signals", "Set the signal handlers to call LDB.", grab_sigs_cmd},
+ {"kill", "Kill ourself with signal number N (useful if running under gdb)",
+ kill_cmd},
{"purify", "Purify. (Caveat purifier!)", purify_cmd},
{"print", "Print object at ADDRESS.", print_cmd},
- {"p", "print", print_cmd},
+ {"p", "Alias for print", print_cmd},
{"quit", "Quit.", quit},
{"regs", "Display current Lisp regs.", regs_cmd},
{"search", "Search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd},
#ifndef alpha
unsigned long *lptr = (unsigned long *)addr;
#else
- u32 *lptr = (unsigned long *)addr;
+ u32 *lptr = (u32 *)addr;
#endif
unsigned short *sptr = (unsigned short *)addr;
unsigned char *cptr = (unsigned char *)addr;
print(obj);
}
+static void kill_cmd(char **ptr)
+{
+ kill(getpid(), parse_number(ptr));
+}
+
static void regs_cmd(char **ptr)
{
printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer);
brief_print((lispobj)(*os_context_register_addr(context,
i*2)));
#else
- brief_print((lispobj)(*os_context_register_addr(context,
- i)));
+ brief_print((lispobj)(*os_context_register_addr(context,i)));
#endif
}
printf("PC:\t\t 0x%08lx\n",
sigint_init();
}
+static FILE *devtty;
+static int devttyfd=-1;
+
static void sub_monitor(void)
{
struct cmd *cmd, *found;
char *line, *ptr, *token;
int ambig;
+ if(devtty==0) {
+ devtty=fopen("/dev/tty","r+");
+ devttyfd=fileno(devtty);
+ }
while (!done) {
printf("ldb> ");
fflush(stdout);
- line = fgets(buf, sizeof(buf), stdin);
+ line = fgets(buf, sizeof(buf), devtty);
if (line == NULL) {
- if (isatty(0)) {
+ if (isatty(devttyfd)) {
putchar('\n');
continue;
}
* register, of the specified offset, for that context. The offset is
* defined in the storage class (SC) defined in the Lisp virtual
* machine (i.e. the file "vm.lisp" for the appropriate architecture). */
-int *os_context_register_addr(os_context_t *context, int offset);
+register_t *os_context_register_addr(os_context_t *context, int offset);
+#ifdef alpha
+register_t *os_context_fpregister_addr(os_context_t *context, int offset);
+#endif
/* Given a signal context, return the address for storage of the
* program counter for that context. */
-int *os_context_pc_addr(os_context_t *context);
+register_t *os_context_pc_addr(os_context_t *context);
/* Given a signal context, return the address for storage of the
* system stack pointer for that context. */
-int *os_context_sp_addr(os_context_t *context);
+register_t *os_context_sp_addr(os_context_t *context);
/* Given a signal context, return the address for storage of the
* signal mask for that context. */
#include "gencgc.h"
#endif
-#undef PRINTNOISE
+#define PRINTNOISE
#if defined(ibmrt) || defined(__i386__)
+/* again, what's so special about the x86 that this is differently
+ * visible there than on other platforms? -dan 20010125
+ */
static lispobj *dynamic_space_free_pointer;
#endif
fflush(stdout);
#endif
#ifndef __i386__
- pscav((lispobj *)control_stack,
+ pscav((lispobj *)CONTROL_STACK_START,
current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
0);
#else
(os_vm_size_t) DYNAMIC_SPACE_SIZE);
}
#else
- os_zero((os_vm_address_t) DYNAMIC_SPACE_START,
+ os_zero((os_vm_address_t) current_dynamic_space,
(os_vm_size_t) DYNAMIC_SPACE_SIZE);
#endif
SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
#if !defined(ibmrt) && !defined(__i386__)
- dynamic_space_free_pointer = DYNAMIC_SPACE_START;
+ dynamic_space_free_pointer = current_dynamic_space;
#else
#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
/* X86 using CGC */
#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))
#define Pointerp(obj) ((obj) & 0x01)
-#define PTR(obj) ((obj)&~lowtag_Mask)
+#define PTR(obj) ((unsigned long)((obj)&~lowtag_Mask))
#define CONS(obj) ((struct cons *)((obj)-type_ListPointer))
#define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer))
* that SBCL runs on as of 0.6.7. If we port to the Alpha or some
* other non-32-bit machine we'll probably need real machine-dependent
* and OS-dependent definitions again. */
-#if defined alpha
-/* We need definitions of u32 and s32. */
-#error Alpha code is stale.
+#if ((defined alpha) && !(defined linux))
+#error No u32,s32 definitions for this platform. Write some.
#else
+/* int happens to be 4 bytes on linux/alpha. long is longer. */
typedef unsigned int u32;
typedef signed int s32;
+#define LOW_WORD(c) ((long)(c) & 0xFFFFFFFFL)
#endif
typedef u32 lispobj;
{
long count, here, data;
- bytes = (bytes+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
+ bytes = (bytes+os_vm_page_size-1)&~(os_vm_page_size-1);
fflush(file);
here = ftell(file);
fseek(file, 0, 2);
- data = (ftell(file)+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
+ data = (ftell(file)+os_vm_page_size-1)&~(os_vm_page_size-1);
fseek(file, data, 0);
while (bytes > 0) {
}
fflush(file);
fseek(file, here, 0);
- return data/CORE_PAGESIZE - 1;
+ return data/os_vm_page_size - 1;
}
static void
data = write_bytes(file, (char *)addr, bytes);
putw(data, file);
- putw((long)addr / CORE_PAGESIZE, file);
- putw((bytes + CORE_PAGESIZE - 1) / CORE_PAGESIZE, file);
+ putw((long)addr / os_vm_page_size, file);
+ putw((bytes + os_vm_page_size - 1) / os_vm_page_size, file);
}
boolean
output_space(file, STATIC_SPACE_ID, (lispobj *)STATIC_SPACE_START,
(lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
#ifdef reg_ALLOC
- output_space(file, DYNAMIC_SPACE_ID, (lispobj *)DYNAMIC_SPACE_START,
+ output_space(file, DYNAMIC_SPACE_ID, (lispobj *)current_dynamic_space,
dynamic_space_free_pointer);
#else
#ifdef GENCGC
F(accept)
F(access)
F(acct)
-#ifndef hpux
-F(adjtime)
-#endif
F(bind)
F(brk)
#if defined(hpux) \
#if !defined(SVR4) || defined(SOLARIS25)
F(setpriority)
#endif
-#if !defined(mach) \
- && !defined(SOLARIS) \
- && !defined(__FreeBSD__) \
- && !defined(__OpenBSD__) \
- && !defined(SUNOS) \
- && !defined(osf1) \
- && !defined(irix) \
- && !defined(hpux)
-F(setquota)
-#endif
#if !defined(hpux) && !defined(SVR4) || defined(SOLARIS25)
F(setregid)
F(setreuid)
F(symlink)
F(sync)
F(syscall)
-#if defined(hpux) || defined(SVR4)
+#if defined(hpux) || defined(SVR4) || defined(linux)
F(closedir)
F(opendir)
+#if defined(readdir)
+#undef reddir
+#endif
F(readdir)
#endif
#if defined(hpux) \
D(daylight)
#endif
D(tzname)
-F(dlopen)
-F(dlsym)
-F(dlclose)
-F(dlerror)
#endif
#if !defined (SOLARIS) || defined(SOLARIS25)
F(getwd)
#ifdef irix
F(_getpty)
#endif
+
+F(dlopen)
+F(dlsym)
+F(dlclose)
+F(dlerror)
ensure_space( (lispobj *)READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE);
ensure_space( (lispobj *)STATIC_SPACE_START , STATIC_SPACE_SIZE);
+#ifdef GENCGC
ensure_space( (lispobj *)DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE);
+#else
+ ensure_space( (lispobj *)DYNAMIC_0_SPACE_START , DYNAMIC_SPACE_SIZE);
+ ensure_space( (lispobj *)DYNAMIC_1_SPACE_START , DYNAMIC_SPACE_SIZE);
+#endif
ensure_space( (lispobj *)CONTROL_STACK_START , CONTROL_STACK_SIZE);
ensure_space( (lispobj *)BINDING_STACK_START , BINDING_STACK_SIZE);
#ifdef HOLES
make_holes();
#endif
+#ifndef GENCGC
+ current_dynamic_space = DYNAMIC_0_SPACE_START;
+#endif
#ifdef PRINTNOISE
printf(" done.\n");
* #include "x86-validate.h"
* #endif
* and so forth. In SBCL, the memory map data are defined at the Lisp
- * level and stuffed into the sbcl.h file created by GENESIS, so
- * there's no longer a need for an architecture-dependent header file
- * of memory map data. */
+ * level (compiler/target/parms.lisp) and stuffed into the sbcl.h file
+ * created by GENESIS, so there's no longer a need for an
+ * architecture-dependent header file of memory map data.
+ */
+
+
#endif
#include <sys/types.h>
#include <dirent.h>
+#include <sys/stat.h>
#include <string.h>
+#include <unistd.h>
#include "util.h"
\f
return result;
}
-/* Free a result returned by alloc_directory_lispy_filenames. */
+/* Free a result returned by alloc_directory_lispy_filenames(). */
void
free_directory_lispy_filenames(char** directory_lispy_filenames)
{
/* Free the table of strings. */
free(directory_lispy_filenames);
}
+\f
+/*
+ * stat(2) stuff
+ */
+
+typedef long my_dev_t;
+
+/* a representation of stat(2) results which doesn't depend on CPU or OS */
+struct stat_wrapper {
+ my_dev_t st_dev; /* device */
+ ino_t st_ino; /* inode */
+ mode_t st_mode; /* protection */
+ nlink_t st_nlink; /* number of hard links */
+ uid_t st_uid; /* user ID of owner */
+ gid_t st_gid; /* group ID of owner */
+ my_dev_t st_rdev; /* device type (if inode device) */
+ off_t st_size; /* total size, in bytes */
+ unsigned long st_blksize; /* blocksize for filesystem I/O */
+ unsigned long st_blocks; /* number of blocks allocated */
+ time_t st_atime; /* time of last access */
+ time_t st_mtime; /* time of last modification */
+ time_t st_ctime; /* time of last change */
+};
+
+static void
+copy_to_stat_wrapper(struct stat_wrapper *to, struct stat *from)
+{
+#define FROB(stem) to->st_##stem = from->st_##stem
+ FROB(dev);
+ FROB(ino);
+ FROB(mode);
+ FROB(nlink);
+ FROB(uid);
+ FROB(gid);
+ FROB(rdev);
+ FROB(size);
+ FROB(blksize);
+ FROB(blocks);
+ FROB(atime);
+ FROB(mtime);
+ FROB(ctime);
+#undef FROB
+}
+
+int
+stat_wrapper(const char *file_name, struct stat_wrapper *buf)
+{
+ struct stat real_buf;
+ int ret;
+ if ((ret = stat(file_name,&real_buf)) >= 0)
+ copy_to_stat_wrapper(buf, &real_buf);
+ return ret;
+}
+
+int
+lstat_wrapper(const char *file_name, struct stat_wrapper *buf)
+{
+ struct stat real_buf;
+ int ret;
+ if ((ret = lstat(file_name,&real_buf)) >= 0)
+ copy_to_stat_wrapper(buf, &real_buf);
+ return ret;
+}
+
+int
+fstat_wrapper(int filedes, struct stat_wrapper *buf)
+{
+ struct stat real_buf;
+ int ret;
+ if ((ret = fstat(filedes,&real_buf)) >= 0)
+ copy_to_stat_wrapper(buf, &real_buf);
+ return ret;
+}
#endif
void
-arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
+arch_do_displaced_inst(os_context_t *context, unsigned int orig_inst)
{
unsigned int *pc = (unsigned int*)(*os_context_pc_addr(context));
--- /dev/null
+/*
+ * The x86 Linux incarnation of arch-dependent OS-dependent routines.
+ * See also linux-os.c
+ */
+
+
+/* header files lifted wholesale from linux-os.c, some may be redundant */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "validate.h"
+size_t os_vm_page_size;
+
+#if defined GENCGC
+#include "gencgc.h"
+#endif
+
+/* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
+ * <sys/ucontext.h> file to define symbolic names for offsets into
+ * gregs[], but it's conditional on __USE_GNU and not defined, so
+ * we need to do this nasty absolute index magic number thing
+ * instead. */
+register_t *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ switch(offset) {
+ case 0: return &context->uc_mcontext.gregs[11]; /* EAX */
+ case 2: return &context->uc_mcontext.gregs[10]; /* ECX */
+ case 4: return &context->uc_mcontext.gregs[9]; /* EDX */
+ case 6: return &context->uc_mcontext.gregs[8]; /* EBX */
+ case 8: return &context->uc_mcontext.gregs[7]; /* ESP */
+ case 10: return &context->uc_mcontext.gregs[6]; /* EBP */
+ case 12: return &context->uc_mcontext.gregs[5]; /* ESI */
+ case 14: return &context->uc_mcontext.gregs[4]; /* EDI */
+ default: return 0;
+ }
+ return &context->uc_mcontext.gregs[offset];
+}
+register_t *
+os_context_pc_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[14];
+}
+register_t *
+os_context_sp_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[17];
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &context->uc_sigmask;
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
+
+;;;; -*- Lisp -*-
;;;; build order
;;;; This software is part of the SBCL system. See the README file for
("code/parse-body") ; on host for PARSE-BODY
("code/parse-defmacro") ; on host for PARSE-DEFMACRO
- ("code/boot-extensions") ; on host for COLLECT etc.
- ("code/early-extensions") ; on host for SYMBOLICATE etc.
- ("code/late-extensions") ; FIXME: maybe no longer needed on host now that
- ; we are no longer doing PRINT-HERALD stuff
+ ("code/extensions") ; on host for COLLECT, SYMBOLICATE, etc.
("compiler/deftype") ; on host for SB!XC:DEFTYPE
("code/early-alieneval") ; for vars needed both at build time and at runtime
("code/string" :not-host)
("code/mipsstrops" :not-host)
+ ("code/target-os-types" :not-host) ; symlinked in make-config.sh
("code/unix" :not-host)
#!+mach ("code/mach" :not-host)
;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN)
;;; was messed up so badly that trying to execute expressions like
;;; this signalled an error.
-(setf (sb-alien:extern-alien "gencgc_oldest_gen_to_gc" sb-alien:unsigned)
- (sb-alien:extern-alien "gencgc_oldest_gen_to_gc" sb-alien:unsigned))
+(setf (sb-alien:extern-alien "current_control_stack_pointer" sb-alien:unsigned)
+ (sb-alien:extern-alien "current_control_stack_pointer" sb-alien:unsigned))
;;; success
(quit :unix-status 104)
(and (not (typep function 'sb-c::byte-function))
(sb-kernel:%function-arglist function)))
(defun check-ext-symbols-arglist (package)
- (format t "~% Looking at Package: ~A" package)
+ (format t "~% looking at package: ~A" package)
(do-external-symbols (ext-sym package)
(when (fboundp ext-sym)
(let ((fun (symbol-function ext-sym)))
--- /dev/null
+all: grovel_headers
+clean:
+ -rm *.o grovel_headers
--- /dev/null
+/* get the sizes and signedness of basic system types. Doing this by
+ * hand is basically just too tedious.
+
+ * In the current system this doesn't get built or run automatically,
+ * because I (Dan) am lazy and do not want to think too hard about the
+ * interaction between generated source files, build trees, and CVS.
+ * You have to build it yourself when porting to a new architecture -
+ * which I'd guess doesn't happen too often anyway
+
+ * The output from this is generally in code/$(architecture)-$(os)-types.h */
+
+#include <sys/types.h>
+#include <sys/times.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#define DEFTYPE(lispname,cname) { cname foo; \
+ printf("(def-alien-type "##lispname##" (%s %d))\n", (((foo=-1)<0) ? "sb!alien:signed" : "unsigned"), (8 * (sizeof foo))); }
+
+#define DEFCONSTANT(lispname,cname) { printf("(defconstant %s %d) ;; 0x%x\n",lispname,cname,cname);}
+
+int
+main(int argc, char *argv[])
+{
+ /* don't need no steenking command line arguments */
+ if (1 != argc) {
+ fprintf(stderr, "argh! command line argument(s)\n");
+ exit(1);
+ }
+
+ /* don't need no steenking hand-editing */
+ printf(
+";;;; This is an automatically generated file, please do not hand-edit it.
+;;;; See the program \"grovel_headers.c\".
+");
+
+ printf("(in-package \"SB!UNIX\")\n\n");
+
+ DEFTYPE("dev-t", dev_t);
+ DEFTYPE("ino-t", ino_t);
+ DEFTYPE("mode-t", mode_t);
+ DEFTYPE("nlink-t", nlink_t);
+ DEFTYPE("uid-t", uid_t);
+ DEFTYPE("gid-t", gid_t);
+ DEFTYPE("clock-t", clock_t);
+ DEFTYPE("off-t", off_t);
+ DEFTYPE("time-t", time_t);
+
+ /* fcntl.h */
+ DEFCONSTANT("r_ok", R_OK);
+ DEFCONSTANT("w_ok", W_OK);
+ DEFCONSTANT("x_ok", X_OK);
+ DEFCONSTANT("f_ok", F_OK);
+
+ /* fcntlbits.h */
+ DEFCONSTANT("o_rdonly", O_RDONLY);
+ DEFCONSTANT("o_wronly", O_WRONLY);
+ DEFCONSTANT("o_rdwr", O_RDWR);
+ DEFCONSTANT("o_accmode", O_ACCMODE);
+ DEFCONSTANT("o_creat", O_CREAT);
+ DEFCONSTANT("o_excl", O_EXCL);
+ DEFCONSTANT("o_noctty", O_NOCTTY);
+ DEFCONSTANT("o_trunc", O_TRUNC);
+ DEFCONSTANT("o_append", O_APPEND);
+ /**/
+ DEFCONSTANT( "s-ifmt", S_IFMT);
+ DEFCONSTANT( "s-ififo", S_IFIFO);
+ DEFCONSTANT( "s-ifchr", S_IFCHR);
+ DEFCONSTANT( "s-ifdir", S_IFDIR);
+ DEFCONSTANT( "s-ifblk", S_IFBLK);
+ DEFCONSTANT( "s-ifreg", S_IFREG);
+
+ DEFCONSTANT( "s-iflnk", S_IFLNK);
+ DEFCONSTANT( "s-ifsock", S_IFSOCK);
+
+ return 0;
+}
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.2"
+"0.6.12.3"
projects / sbcl.git / commitdiff