X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=f1f1c9612618343101e4719dbf5bc567c77508c4;hb=07ab1e4811ab16f95a9a5e8d767426a0787f22c0;hp=55a0e575c065e62469d941cb65f5cc5777b77c09;hpb=8fee0ba99cd1b1038072bd3fc8f5d5338d80d2de;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 55a0e57..f1f1c96 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -870,7 +870,7 @@ core and return a descriptor to it." (defun cold-set-layout-slot (cold-layout slot-name value) (write-wordindexed cold-layout - (+ sb-vm:instance-slots-offset (target-layout-index slot-name)) + (+ sb!vm:instance-slots-offset (target-layout-index slot-name)) value)) ;;; Return a list of names created from the cold layout INHERITS data @@ -959,6 +959,7 @@ core and return a descriptor to it." (cold-set-layout-slot result 'info *nil-descriptor*) (cold-set-layout-slot result 'pure *nil-descriptor*) (cold-set-layout-slot result 'n-untagged-slots nuntagged) + (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*) (setf (gethash name *cold-layouts*) (list result @@ -1107,7 +1108,8 @@ core and return a descriptor to it." *cl-package* ;; ordinary case (let ((result (symbol-package symbol))) - (aver (package-ok-for-target-symbol-p result)) + (unless (package-ok-for-target-symbol-p result) + (bug "~A in bad package for target: ~A" symbol result)) result)))) ;;; Return a handle on an interned symbol. If necessary allocate the @@ -2665,10 +2667,11 @@ core and return a descriptor to it." (when (constantp symbol) (let ((name (symbol-name symbol))) (labels ( ;; shared machinery - (record (string priority) + (record (string priority suffix) (push (list string priority (symbol-value symbol) + suffix (documentation symbol 'variable)) constants)) ;; machinery for old-style CMU CL Lisp-to-C @@ -2680,7 +2683,8 @@ core and return a descriptor to it." 'simple-string prefix (delete #\- (string-capitalize string))) - priority)) + priority + "")) (maybe-record-with-munged-name (tail prefix priority) (when (tailwise-equal name tail) (record-with-munged-name prefix @@ -2689,23 +2693,23 @@ core and return a descriptor to it." (length tail))) priority))) ;; machinery for new-style SBCL Lisp-to-C naming - (record-with-translated-name (priority) - (record (c-name name) priority)) - (maybe-record-with-translated-name (suffixes priority) + (record-with-translated-name (priority large) + (record (c-name name) priority (if large "LU" ""))) + (maybe-record-with-translated-name (suffixes priority &key large) (when (some (lambda (suffix) (tailwise-equal name suffix)) suffixes) - (record-with-translated-name priority)))) - + (record-with-translated-name priority large)))) (maybe-record-with-translated-name '("-LOWTAG") 0) - (maybe-record-with-translated-name '("-WIDETAG") 1) + (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1) (maybe-record-with-munged-name "-FLAG" "flag_" 2) (maybe-record-with-munged-name "-TRAP" "trap_" 3) (maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4) (maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5) - (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6) - (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7) - (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8)))))) + (maybe-record-with-translated-name '("-SIZE") 6) + (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t) + (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8) + (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)))))) ;; KLUDGE: these constants are sort of important, but there's no ;; pleasing way to inform the code above about them. So we fake ;; it for now. nikodemus on #lisp (2004-08-09) suggested simply @@ -2719,6 +2723,7 @@ core and return a descriptor to it." (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) + "" nil) constants)) ;; One more symbol that doesn't fit into the code above. @@ -2726,9 +2731,9 @@ core and return a descriptor to it." (push (list (c-symbol-name c) 9 (symbol-value c) + "LU" nil) constants)) - (setf constants (sort constants (lambda (const1 const2) @@ -2737,33 +2742,13 @@ core and return a descriptor to it." (< (second const1) (second const2)))))) (let ((prev-priority (second (car constants)))) (dolist (const constants) - (destructuring-bind (name priority value doc) const + (destructuring-bind (name priority value suffix doc) const (unless (= prev-priority priority) (terpri) (setf prev-priority priority)) - (format t "#define ~A " name) - (format t - ;; KLUDGE: We're dumping two different kinds of - ;; values here, (1) small codes and (2) machine - ;; addresses. The small codes can be dumped as bare - ;; integer values. The large machine addresses might - ;; cause problems if they're large and represented - ;; as (signed) C integers, so we want to force them - ;; to be unsigned by appending an U to the - ;; literal. We can't dump all the values using the - ;; literal-U syntax, since the assembler doesn't - ;; support that syntax and some of the small - ;; constants can be used in assembler files. - (let ( ;; cutoff for treatment as a small code - (cutoff (expt 2 16))) - (cond ((minusp value) - (error "stub: negative values unsupported")) - ((< value cutoff) - "~D") - (t - "~DU"))) - value) - (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc)))) + (when (minusp value) + (error "stub: negative values unsupported")) + (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc)))) (terpri)) ;; writing information about internal errors @@ -2781,7 +2766,7 @@ core and return a descriptor to it." ;; I'm not really sure why this is in SB!C, since it seems ;; conceptually like something that belongs to SB!VM. In any case, ;; it's needed C-side. - (format t "#define BACKEND_PAGE_SIZE ~DU~%" sb!c:*backend-page-size*) + (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*) (terpri) @@ -2976,17 +2961,17 @@ initially undefined function references:~2%") (force-output *core-file*) (file-position *core-file* (round-up (file-position *core-file*) - sb!c:*backend-page-size*))) + sb!c:*backend-page-bytes*))) (defun output-gspace (gspace) (force-output *core-file*) (let* ((posn (file-position *core-file*)) (bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes)) - (pages (ceiling bytes sb!c:*backend-page-size*)) - (total-bytes (* pages sb!c:*backend-page-size*))) + (pages (ceiling bytes sb!c:*backend-page-bytes*)) + (total-bytes (* pages sb!c:*backend-page-bytes*))) (file-position *core-file* - (* sb!c:*backend-page-size* (1+ *data-page*))) + (* sb!c:*backend-page-bytes* (1+ *data-page*))) (format t "writing ~S byte~:P [~S page~:P] from ~S~%" total-bytes @@ -3016,7 +3001,7 @@ initially undefined function references:~2%") (write-word (gspace-free-word-index gspace)) (write-word *data-page*) (multiple-value-bind (floor rem) - (floor (gspace-byte-address gspace) sb!c:*backend-page-size*) + (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*) (aver (zerop rem)) (write-word floor)) (write-word pages)