* Fix a stray #+ -> #!+.
* Removed unneeded nops.
* Explanation of magic numbers (but not yet substituted.)
(Above changes in patch by Larry Valkama)
* Fix a bunch of comments in the HPPA backend to use the right number
of semicolons, and use FIXME-lav instead of FIX-lav to mark things
(better grepping for the rest of us.)
floating point stuff. Various patches and fixes of his have been
ported to SBCL, including his Sparc port of linkage-table.
+Larry Valkama:
+ He resurrected the HPUX port, and worked on the HPPA backend in
+ general.
+
Peter Van Eynde:
He wrestled the CLISP test suite into a mostly portable test suite
(clocc ansi-test) which can be used on SBCL, provided a slew of
DTC Douglas Crosher
JES Juho Snellman
JRXR Joshua Ross
+LAV Larry Valkama
MG Gabor Melis
MNA Martin Atzmueller
NJF Nathan Froyd
PVE Peter Van Eynde
PW Paul Werkowski
RAM Robert MacLachlan
+TCR Tobias Rittweiler
THS Thiemo Seufer
VJA Vincent Arkesteijn
WHN William ("Bill") Newman
(:temporary (:sc interior-reg :offset lip-offset) lip)
(:ignore lip sign) ; fix-lav: why dont we ignore tmp ?
(:generator 30
- ; looking at the register setup above, not sure if both can clash
- ; maybe it is ok that x and x-pass share register ? like it was
+ ;; looking at the register setup above, not sure if both can clash
+ ;; maybe it is ok that x and x-pass share register ? like it was
(unless (location= y y-pass)
(inst sra x 2 x-pass))
(let ((fixup (make-fixup 'multiply :assembly-routine)))
(inst bc := nil y zero-tn zero))
(move x x-pass)
(move y y-pass)
- ; really dirty trick to avoid the bug truncate/unsigned vop
- ; followed by move-from/word->fixnum where the result from
- ; the truncate is 0xe39516a7 and move-from-word will treat
- ; the unsigned high number as an negative number.
- ; instead we clear the high bit in the input to truncate.
+ ;; really dirty trick to avoid the bug truncate/unsigned vop
+ ;; followed by move-from/word->fixnum where the result from
+ ;; the truncate is 0xe39516a7 and move-from-word will treat
+ ;; the unsigned high number as an negative number.
+ ;; instead we clear the high bit in the input to truncate.
(inst li #x1fffffff q)
(inst comb :<> q y skip :nullify t)
(inst addi -1 zero-tn q)
(inst and x-pass q x-pass)
(inst and y-pass q y-pass)
SKIP
- ; fix bug#2 (truncate #xe39516a7 #x3) => #0xf687078d,#x0
+ ;; fix bug#2 (truncate #xe39516a7 #x3) => #0xf687078d,#x0
(inst li #x7fffffff q)
(inst and x-pass q x-pass)
(let ((fixup (make-fixup 'truncate :assembly-routine)))
(:temporary (:scs (non-descriptor-reg)) header)
(:results (result :scs (descriptor-reg)))
(:generator 13
- ; Note: Cant use addi, the immediate is too large
+ ;; Note: Cant use addi, the immediate is too large
(inst li (+ (* (1+ array-dimensions-offset) n-word-bytes)
lowtag-mask) header)
(inst add header rank bytes)
(in-package "SB!VM")
-; beware that we deal alot here with register-offsets directly
-; instead of their symbol-name in vm.lisp
-; offset works differently depending on sc-type
+;;; beware that we deal alot here with register-offsets directly
+;;; instead of their symbol-name in vm.lisp
+;;; offset works differently depending on sc-type
(defun my-make-wired-tn (prim-type-name sc-name offset state)
(make-wired-tn (primitive-type-or-lose prim-type-name)
(sc-number-or-lose sc-name)
- ; try to utilize vm.lisp definitions of registers:
+ ;; try to utilize vm.lisp definitions of registers:
(ecase sc-name
((any-reg sap-reg signed-reg unsigned-reg)
(ecase offset ; FIX: port to other arch ???
(3 nl3-offset)))
((single-reg double-reg) ; only for return
(+ 4 offset))
- ; A tn of stack type tells us that we have data on
- ; stack. This offset is current argument number so
- ; -1 points to the correct place to write that data
+ ;; A tn of stack type tells us that we have data on
+ ;; stack. This offset is current argument number so
+ ;; -1 points to the correct place to write that data
((sap-stack signed-stack unsigned-stack)
(- (arg-state-nargs state) offset 8 1)))))
(:temporary (:sc any-reg :offset cfunc-offset
:from (:argument 0) :to (:result 0)) cfunc)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
- ; Not sure if using nargs is safe ( have we saved it ).
- ; but we cant use any non-descriptor-reg because c-args nl-4 is of that type
+ ;; Not sure if using nargs is safe ( have we saved it ).
+ ;; but we cant use any non-descriptor-reg because c-args nl-4 is of that type
(:temporary (:sc non-descriptor-reg :offset nargs-offset) temp)
(:vop-var vop)
(:generator 0
(:results (result :scs (sap-reg any-reg)))
(:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:generator 0
- ; Because stack grows to higher addresses, we have the result
- ; pointing to an lowerer address than nsp
+ ;; Because stack grows to higher addresses, we have the result
+ ;; pointing to an lowerer address than nsp
(move nsp-tn result)
(unless (zerop amount)
- ; hp-ux stack grows towards larger addresses and stack must be
- ; allocated in blocks of 64 bytes
+ ;; hp-ux stack grows towards larger addresses and stack must be
+ ;; allocated in blocks of 64 bytes
(let ((delta (+ 0 (logandc2 (+ amount 63) 63)))) ; was + 16
(cond ((< delta (ash 1 10))
(inst addi delta nsp-tn nsp-tn))
(lisp-return lra-arg :offset 2)
;; Nope, not the single case.
(emit-label not-single)
+ ;; most of these moves will not be emitted and therefor
+ ;; isn't suitable to put in the delay slot below. But if
+ ;; you do, dont forget to force-emit as in (move src dst t)
(move ocfp-arg ocfp)
(move lra-arg lra)
(move vals-arg vals)
- (move nvals-arg nvals) ; FIX-lav: cant utilize branch-delay-slot, why?
+ (move nvals-arg nvals)
(let ((fixup (make-fixup 'return-multiple :assembly-routine)))
(inst ldil fixup tmp)
(inst be fixup lisp-heap-space tmp :nullify t)))
;;; Copy a more arg from the argument area to the end of the current frame.
;;; Fixed is the number of non-more arguments.
-;;; FIX-lav: old hppa code look smarter.
+;;; FIXME-lav: old hppa code look smarter.
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:temporary (:sc any-reg :offset nl1-offset) count)
(inst add nargs-tn cfp-tn src)
(emit-label loop)
- ; decrease src, then load src into temp
+ ;; decrease src, then load src into temp
(inst ldwm (- n-word-bytes) src temp)
- ; increase, compare if count >= to zero, if true, jump
+ ;; increase, compare if count >= to zero, if true, jump
(inst addib :>= (fixnumize -1) count loop)
- ; decrease dst, then store temp at dst
+ ;; decrease dst, then store temp at dst
(inst stwm temp (- n-word-bytes) dst)
(emit-label do-regs)
(:generator 2
(loadw temp symbol symbol-hash-slot other-pointer-lowtag)
(inst dep 0 31 n-fixnum-tag-bits temp)
- ; we must go through an temporary to avoid gc
+ ;; we must go through an temporary to avoid gc
(move temp res)))
\f
(:policy :fast-safe)
(:args (object :scs (sap-reg)))
(:info offset)
- ; make room for multiply by limiting to 12 bits
+ ;; make room for multiply by limiting to 12 bits
(:arg-types system-area-pointer (:constant (signed-byte 12)))
(:results (result :scs (descriptor-reg)))
(:result-types *)
(inst fsts x offset base))
((and (< offset (ash 1 13))
(> offset 0))
- ; FIX-lav, ok with GC to use lip-tn for arbitrary offsets ?
+ ;; FIXME-lav, ok with GC to use lip-tn for arbitrary offsets ?
(inst ldo offset zero-tn lip-tn)
;(note-next-instruction vop :internal-error)
(inst fstx x lip-tn base))
(double-stack y)
(double-int-carg-reg temp)))
(offset (* (tn-offset stack-tn) n-word-bytes)))
- ; save 8 bytes of stack to two register,
- ; write down float in stack and load it back
- ; into result register. Notice the result hack,
- ; we are writing to one extra register.
- ; Double float argument convention uses two registers,
- ; but we only know about one (thanks to c-call).
+ ;; save 8 bytes of stack to two register,
+ ;; write down float in stack and load it back
+ ;; into result register. Notice the result hack,
+ ;; we are writing to one extra register.
+ ;; Double float argument convention uses two registers,
+ ;; but we only know about one (thanks to c-call).
(inst ldw offset nfp old1)
(inst ldw (+ offset n-word-bytes) nfp old2)
(str-float x offset nfp) ; writes 8 bytes
(define-vop (,dname double-float-compare)
(:translate ,translate)
(:variant ,condition ,complement)))))
- ;FIX-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here
+ ;; FIXME-lav: let 'inst cmp' translate keywords into raw binary instead of giving it here
(frob < #b01001 #b10101 </single-float </double-float)
(frob > #b10001 #b01101 >/single-float >/double-float)
(frob = #b00101 #b11001 eql/single-float eql/double-float))
\f
;;;; Initial disassembler setup.
-;FIX-lav: is this still used, if so , why use package prefix
-;(setf sb!disassem:*disassem-inst-alignment-bytes* 4)
+
+;;; FIXME-lav: is this still used, if so , why use package prefix
+;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
(defvar *disassem-use-lisp-reg-names* t)
(:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
cond-kind
"-CONDITION"))))
- ;FIX-lav, change opcode test to name test
- ,@(when (= opcode #x12)
+ ,@(when (eq name 'or)
`((:printer r3-inst ((op ,opcode) (r2 0)
(c nil :type ',(symbolicate cond-kind
"-CONDITION")))
(assemble (segment vop)
(cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
(inst comb (maybe-negate-cond cond not-p) r1 r2 target)
- (inst nop)) ;FIX-lav, cant nullify when backward branch
+ (inst nop)) ; FIXME-lav, cant nullify when backward branch
(t
(inst comclr r1 r2 zero-tn
(maybe-negate-cond cond (not not-p)))
(emit-chooser
;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
segment 12 3
- ; This is the best-case that emits one instruction ( 4 bytes )
+ ;; This is the best-case that emits one instruction ( 4 bytes )
(lambda (segment posn delta-if-after)
(let ((delta (funcall calc label posn delta-if-after)))
- ; WHEN, Why not AVER ?
+ ;; WHEN, Why not AVER ?
(when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
(emit-back-patch segment 4
(lambda (segment posn)
(inst addi (funcall calc label posn 0) src
dst))))
t)))
- ; This is the worst-case that emits three instruction ( 12 bytes )
+ ;; This is the worst-case that emits three instruction ( 12 bytes )
(lambda (segment posn)
(let ((delta (funcall calc label posn 0)))
- ; FIX-lav: why do we hit below check ?
- ;(when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
- ; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
+ ;; FIXME-lav: why do we hit below check ?
+ ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
;; Note: if we used addil/ldo to do this in 2 instructions then the
;; intermediate value would be tagged but pointing into space.
;; Does above note mean that the intermediate value would be
;; a bogus pointer that would be GCed wrongly ?
;; Also what I can see addil would also overwrite NFP (r1) ???
(assemble (segment vop)
- ; Three instructions (4 * 3) this is the reason for 12 bytes
+ ;; Three instructions (4 * 3) this is the reason for 12 bytes
(inst ldil delta temp)
(inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
(inst add src temp dst))))))
(,gensym))))
;;; Instruction-like macros.
-;;; FIX-lav: add if always-emit-code-p is :e= then error if location=
+;;; FIXME-lav: add if always-emit-code-p is :e= then error if location=
(defmacro move (src dst &optional always-emit-code-p)
#!+sb-doc
"Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P is nil)."
"Emit a return-pc header word. LABEL is the label to use for this
return-pc."
`(progn
- ; alignment causes the return point to land on two address,
- ; where the first must be nop pad.
+ ;; alignment causes the return point to land on two address,
+ ;; where the first must be nop pad.
(emit-alignment n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
write-body)
,@body)))))
-;; is used for stack allocation of dynamic-extent objects
-; FIX-lav, if using defun, atleast surround in assembly-form ? macro better ?
+;;; is used for stack allocation of dynamic-extent objects
+;;; FIXME-lav, if using defun, atleast surround in assembly-form ? macro better ?
(defun align-csp (temp)
(declare (ignore temp))
(let ((aligned (gen-label)))
(define-vop (nlx-entry)
- (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops
- ; would be inserted before the LRA.
+ (: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))
(move null-tn tn))
(control-stack
(store-stack-tn tn null-tn)))))
- (inst b defaulting-done)
- (inst nop)))))) ; FIX remove me or tell why I'm needed
+ (inst b defaulting-done :nullify t))))))
(load-stack-tn csp-tn sp)))
(sc-case new-start
(any-reg (move dst new-start))
(control-stack (store-stack-tn new-start dst)))
- (inst comb := num zero-tn done)
- (inst nop) ; fix-lav remove nop
+ (inst comb := num zero-tn done :nullify t)
(sc-case new-count
(any-reg (move num new-count))
(control-stack (store-stack-tn new-count num)))
(in-package "SB!VM")
-; FIX-lav, can we do this in assembly instead ?
+;;; FIXME-lav, can we do this in assembly instead ?
(defun sanctify-for-execution (component)
(without-gcing
(alien-funcall (extern-alien "sanctify_for_execution"
(inst and object temp2 result)
(inst comb :<> result zero-tn LOWTAG-ONLY :nullify t)
- ; must be an other immediate
+ ;; must be an other immediate
(inst li widetag-mask temp2)
(inst b DONE)
(inst and temp2 object result)
FUNCTION-PTR
(load-type result object (- fun-pointer-lowtag))
- (inst b done)
- (inst nop)
+ (inst b done :nullify t)
LOWTAG-ONLY
(inst li lowtag-mask temp1)
OTHER-PTR
(load-type result object (- other-pointer-lowtag))
- (inst nop)
DONE))
-
(define-vop (fun-subtype)
(:translate fun-subtype)
(:policy :fast-safe)
(:results (result :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 6
- (load-type result function (- fun-pointer-lowtag))
- (inst nop))) ;FIX-lav, not sure this nop is needed
+ (load-type result function (- fun-pointer-lowtag))))
(define-vop (set-fun-subtype)
(:translate (setf fun-subtype))
(:generator 6
(loadw res x 0 fun-pointer-lowtag)
(inst srl res n-widetag-bits res)))
-;FIX-lav, not sure we need data of type immediate and zero, test without, if so revert to old hppa code
+;;; FIXME-lav, not sure we need data of type immediate and zero, test without,
+;;; if so revert to old hppa code
(define-vop (set-header-data)
(:translate set-header-data)
(:policy :fast-safe)
(:temporary (:scs (non-descriptor-reg)) t1 t2)
(:generator 6
(loadw t1 x 0 other-pointer-lowtag)
- ; replace below 2 inst with: (mask widetag-mask t1 t1)
+ ;; replace below 2 inst with: (mask widetag-mask t1 t1)
(inst li widetag-mask t2)
(inst and t1 t2 t1)
(sc-case data
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:generator 10
(loadw ndescr code 0 other-pointer-lowtag)
- ;FIX-lav: replace below two with DEPW
+ ;; FIXME-lav: replace below two with DEPW
(inst srl ndescr n-widetag-bits ndescr)
(inst sll ndescr word-shift ndescr)
(inst add ndescr offset ndescr)
(:generator 1
(inst break halt-trap)))
-#+hpux
+#!+hpux
(define-vop (setup-return-from-lisp-stub)
(:results)
(:save-p t)
;; Get the second digit.
(loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
- ; Dont nullify comb here, because we cant guarantee target is forward
+ ;; Dont nullify comb here, because we cant guarantee target is forward
(inst comb (if not-p := :<>) temp zero-tn not-target)
(inst nop)
(inst b target)
;;;
;;; Handy macro so we don't have to keep changing all the numbers whenever
;;; we insert a new storage class.
-;;; FIX-lav: move this into arch-generic-helpers.lisp and rip out from arches
+;;; FIXME-lav: move this into arch-generic-helpers.lisp and rip out from arches
(defmacro !define-storage-classes (&rest classes)
(do ((forms (list 'progn)
(let* ((class (car classes))
\f
;;;; Make some random tns for important registers.
-; how can we address reg L0 through L0-offset when it is not
-; defined here ? do all registers have an -offset and this is
-; redundant work ?
-;FIX-lav: move this into arch-generic-helpers
+
+;;; how can we address reg L0 through L0-offset when it is not
+;;; defined here ? do all registers have an -offset and this is
+;;; redundant work ?
+;;;
+;;; FIXME-lav: move this into arch-generic-helpers
(macrolet ((defregtn (name sc)
(let ((offset-sym (symbolicate name "-OFFSET"))
(tn-sym (symbolicate name "-TN")))
(defregtn zero any-reg)
(defregtn nargs any-reg)
- ;FIX-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
- (defregtn fdefn descriptor-reg) ; FIX-lav, not used
- (defregtn lexenv descriptor-reg) ; FIX-lav, not used
+ ;; FIXME-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
+ (defregtn fdefn descriptor-reg) ; FIXME-lav, not used
+ (defregtn lexenv descriptor-reg) ; FIXME-lav, not used
(defregtn nfp descriptor-reg) ; why not descriptor-reg ?
(defregtn ocfp any-reg) ; why not descriptor-reg ?
#ifdef LISP_FEATURE_HPUX
extern void *return_from_lisp_stub;
+#include "genesis/closure.h"
+#include "genesis/simple-fun.h"
#endif
\f
lose("couldn't find initial function\n");
}
#ifdef LISP_FEATURE_HPUX
+ /* -1 = CLOSURE_FUN_OFFSET, 23 = SIMPLE_FUN_CODE_OFFSET, we are not in LANGUAGE_ASSEMBLY
+ so we cant reach them. */
return_from_lisp_stub = (void *) ((char *)*((unsigned long *)
- ((char *)initial_function - 1)) + 23);
+ ((char *)initial_function + -1)) + 23);
#endif
gc_initialize_pointers();
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.24.29"
+"1.0.24.30"
projects / sbcl.git / commitdiff