Commit 76b5e40b authored by wlott's avatar wlott
Browse files

Merged MIPS branch with the trunk.

parent 9b2a483f
This diff is collapsed.
......@@ -18,6 +18,15 @@
;;;; Utilities used during code generation.
;;; Component-Header-Length -- Interface
;;;
(defun component-header-length (&optional (component *compile-component*))
"Returns the number of bytes used by the code object header."
(let* ((2comp (component-info component))
(constants (ir2-component-constants 2comp))
(num-consts (length constants)))
(ash (logandc2 (1+ num-consts) 1) vm:word-shift)))
;;; SB-Allocated-Size -- Interface
;;;
(defun sb-allocated-size (name)
......@@ -58,6 +67,18 @@
(ir2-environment-return-pc-pass 2env))
;;;; Generate-code and support routines.
(defvar *code-segment* nil)
(defvar *elsewhere* nil)
;;; Init-Assembler -- Interface
;;;
(defun init-assembler ()
(setf *code-segment* (make-segment))
(setf *elsewhere* (make-segment))
(undefined-value))
;;; Generate-Code -- Interface
;;;
(defun generate-code (component)
......@@ -66,7 +87,8 @@
(let ((1block (ir2-block-block block)))
(when (and (eq (block-info 1block) block)
(block-start 1block))
(emit-label (block-label 1block))
(assemble (*code-segment* nil)
(emit-label (block-label 1block)))
(let ((env (block-environment 1block)))
(unless (eq env prev-env)
(let ((lab (gen-label)))
......@@ -82,5 +104,15 @@
(funcall gen vop)
(format t "Missing generator for ~S.~%"
(template-name (vop-info vop))))))))
(assemble (*code-segment* nil)
(insert-segment *elsewhere*))
(finalize-segment *code-segment*))
(defun emit-label-elsewhere (label)
(assemble (*elsewhere* nil)
(emit-label label)))
(finish-assembly))
(defun label-elsewhere-p (label)
(<= (label-position *elsewhere*) (label-position label)))
......@@ -110,7 +110,7 @@
0)
*byte-buffer*)
(let ((loc (label-location label)))
(let ((loc (label-position label)))
(write-var-integer (- loc *previous-location*) *byte-buffer*)
(setq *previous-location* loc))
......@@ -498,9 +498,8 @@
;;; at some particular time (after assembly) so that source map information is
;;; available.
;;;
(defun debug-info-for-component (component assem-nodes count)
(declare (type component component) (simple-vector assem-nodes)
(type index count))
(defun debug-info-for-component (component)
(declare (type component component))
(let ((level (cookie-debug *default-cookie*))
(res (make-compiled-debug-info :name (component-name component)
:package (package-name *package*))))
......@@ -525,11 +524,11 @@
(ir2-environment-return-pc 2env))
:old-fp (tn-sc-offset
(ir2-environment-old-fp 2env))
:start-pc (label-location
:start-pc (label-position
(ir2-environment-environment-start 2env))
:elsewhere-pc
(label-location
(label-position
(ir2-environment-elsewhere-start 2env)))))
(when (>= level 1)
......@@ -556,7 +555,7 @@
(setf (compiled-debug-function-returns dfun)
(compute-debug-returns fun)))))))
(dfuns (cons (label-location
(dfuns (cons (label-position
(block-label
(node-block
(lambda-bind fun))))
......
......@@ -7,6 +7,8 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.13 1990/08/24 18:35:02 wlott Exp $
;;;
;;; Utilities for debugging the compiler. Currently contains only stuff for
;;; checking the consistency of the IR1.
;;;
......@@ -1065,15 +1067,22 @@
(defun print-tn (tn &optional (stream *standard-output*))
(declare (type tn tn))
(let ((leaf (tn-leaf tn)))
(cond (leaf
(cond #-new-compiler
(leaf
(xp::princ (with-output-to-string (stream)
(print-leaf leaf stream))
stream)
(xp::format stream "!~D" (tn-id tn)))
#+new-compiler
(leaf
(print-leaf leaf stream)
(format stream "!~D" (tn-id tn)))
(t
(xp::format stream "t~D" (tn-id tn))))
(#-new-compiler xp::format #+new-compiler format
stream "t~D" (tn-id tn))))
(when (and (tn-sc tn) (tn-offset tn))
(xp::format stream "[~A]" (location-print-name tn)))))
(#-new-compiler xp::format #+new-compiler format
stream "[~A]" (location-print-name tn)))))
;;; Print-Operands -- Internal
......@@ -1083,7 +1092,8 @@
;;;
(defun print-operands (refs)
(declare (type (or tn-ref null) refs))
(xp:within-logical-block (nil nil)
(#-new-compiler xp:within-logical-block #-new-compiler (nil nil)
#+new-compiler progn
(do ((ref refs (tn-ref-across ref)))
((null ref))
(let ((tn (tn-ref-tn ref))
......@@ -1092,9 +1102,11 @@
(print-tn tn))
(t
(print-tn tn)
(xp::princ (if (tn-ref-write-p ref) #\< #\>))
(#-new-compiler xp::princ #+new-compiler princ
(if (tn-ref-write-p ref) #\< #\>))
(print-tn ltn)))
(xp::princ #\space)
(#-new-compiler xp::princ #+new-compiler princ #\space)
#-new-compiler
(xp:conditional-newline :fill)))))
......@@ -1103,6 +1115,7 @@
;;; Print the vop on a single line.
;;;
(defun print-vop (vop)
#-new-compiler
(xp:within-logical-block (nil nil)
(xp::princ (vop-info-name (vop-info vop)))
(xp::princ #\space)
......@@ -1118,7 +1131,21 @@
(when (vop-results vop)
(xp::princ "=> ")
(print-operands (vop-results vop))))
(xp::terpri))
#-new-compiler
(xp::terpri)
#+new-compiler
(progn
(princ (vop-info-name (vop-info vop)))
(princ #\space)
(print-operands (vop-args vop))
(when (vop-codegen-info vop)
(let ((*print-level* 1)
(*print-length* 3))
(format t "{~{~S~^ ~}} " (vop-codegen-info vop))))
(when (vop-results vop)
(princ "=> ")
(print-operands (vop-results vop)))
(terpri)))
;;; Print-IR2-Block -- Internal
;;;
......
......@@ -7,6 +7,8 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/eval.lisp,v 1.13 1990/08/24 18:35:11 wlott Exp $
;;;
;;; This file contains the interpreter. We first convert to the compiler's
;;; IR1 and interpret that.
;;;
......@@ -254,7 +256,7 @@
(declare (ignore ig1 ig2))
res))
;;;
(defun (setf interpreted-function-name) (x val)
(defun (setf interpreted-function-name) (val x)
(let* ((eval-fun (get-eval-function x))
(def (eval-function-definition eval-fun)))
(when def
......@@ -266,7 +268,7 @@
(defun interpreted-function-arglist (x)
(eval-function-arglist (get-eval-function x)))
;;;
(defun (setf interpreted-function-arglist) (x val)
(defun (setf interpreted-function-arglist) (val x)
(setf (eval-function-arglist (get-eval-function x)) val))
......@@ -464,7 +466,7 @@
;; binding mechanism to unbind one variable.
(eval-stack-pop)
(maybe-trace-funny-fun node ,name)
(system:%primitive unbind 1))
(system:%primitive unbind))
(c::%catch
(let* ((tag (eval-stack-pop))
(nlx-info (eval-stack-pop))
......
......@@ -7,15 +7,17 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.10 1990/08/24 18:35:19 wlott Exp $
;;;
;;; This file defines all the standard functions to be known functions.
;;; Each function has type and side-effect information, and may also have IR1
;;; optimizers.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)
(in-package "C")
(in-package 'lisp)
(in-package "LISP")
(import '(
%aset
%bitset
......@@ -29,6 +31,7 @@
%set-documentation
%set-fdefinition
%set-fill-pointer
%set-row-major-aref
%setelt
%setnth
%sp-set-definition
......@@ -39,6 +42,7 @@
%typep
%array-typep
array-header-p
base-char-p
double-float-p
long-float-p
short-float-p
......@@ -385,21 +389,13 @@
(defknown character (t) character (movable foldable flushable))
(defknown char-code (character) char-code (movable foldable flushable))
(defknown char-bits (character) char-bits (movable foldable flushable))
(defknown char-font (character) char-font (movable foldable flushable))
(defknown code-char (char-code &optional char-bits char-font)
character (movable foldable flushable))
(defknown make-char (character &optional char-bits char-font)
character (movable foldable flushable))
(defknown code-char (char-code) base-character (movable foldable flushable))
(defknown (char-upcase char-downcase) (character) character (movable foldable flushable))
(defknown digit-char (integer &optional integer char-bits)
(or character null) (movable foldable flushable))
(defknown char-int (character) char-int (movable foldable flushable))
(defknown int-char (char-int) character (movable foldable flushable))
(defknown char-int (character) char-code (movable foldable flushable))
(defknown char-name (character) (or simple-string null) (movable foldable flushable))
(defknown name-char (stringable) (or character null) (movable foldable flushable))
(defknown char-bit (character bit-names) boolean (movable foldable flushable))
(defknown set-char-bit (character bit-names t) character (movable foldable flushable))
;;;; In the "Sequences" chapter:
......@@ -681,6 +677,7 @@
(defknown vector (&rest t) simple-vector (flushable unsafe))
(defknown aref (array &rest index) t (foldable flushable))
(defknown row-major-aref (array index) t (foldable flushable))
(defknown array-element-type (array) type-specifier (foldable flushable))
(defknown array-rank (array) array-rank (foldable flushable))
......@@ -725,8 +722,8 @@
;;;; In the "Strings" chapter:
(defknown char (string index) string-char (foldable flushable))
(defknown schar (simple-string index) string-char (foldable flushable))
(defknown char (string index) character (foldable flushable))
(defknown schar (simple-string index) character (foldable flushable))
(defknown (string= string-equal)
(stringlike stringlike &key (start1 index) (end1 sequence-end)
......@@ -742,7 +739,7 @@
(or index null)
(foldable flushable))
(defknown make-string (index &key (initial-element string-char))
(defknown make-string (index &key (initial-element character))
simple-string (flushable))
(defknown (string-trim string-left-trim string-right-trim)
......@@ -943,8 +940,8 @@
(defknown file-length (stream) (or unsigned-byte null) (flushable))
(defknown load
(filename &key (verbose t) (print t)
(if-does-not-exist (member :error :create nil)))
((or filename stream)
&key (verbose t) (print t) (if-does-not-exist (member :error :create nil)))
t)
(defknown directory (pathnamelike &key) list (flushable))
......@@ -1044,8 +1041,12 @@
(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
(movable foldable flushable))
(defknown %negate (number) number (movable foldable flushable))
(defknown %check-bound (array index fixnum) index (movable foldable flushable))
(defknown data-vector-ref (array index) t (foldable flushable))
(defknown data-vector-set (array index t) t (unsafe))
(defknown kernel:%caller-frame-and-pc () (values t t) (flushable))
;;; Structure slot accessors or setters are magically "known" to be these
;;; functions, although the var remains the Slot-Accessor describing the actual
;;; function called.
......@@ -1057,6 +1058,7 @@
;;;; Setf inverses:
(defknown %aset (array &rest t) t (unsafe))
(defknown %set-row-major-aref (array index t) t (unsafe))
(defknown %rplaca (cons t) t (unsafe))
(defknown %rplacd (cons t) t (unsafe))
(defknown %put (symbol t t) t (unsafe))
......@@ -1064,8 +1066,8 @@
(defknown %svset (simple-vector index t) t (unsafe))
(defknown %bitset (bit-vector index bit) bit (unsafe))
(defknown %sbitset (simple-bit-vector index bit) bit (unsafe))
(defknown %charset (string index string-char) string-char (unsafe))
(defknown %scharset (simple-string index string-char) string-char (unsafe))
(defknown %charset (string index character) character (unsafe))
(defknown %scharset (simple-string index character) character (unsafe))
(defknown %sp-set-definition (symbol function) function (unsafe))
(defknown %sp-set-plist (symbol t) t (unsafe))
(defknown %set-documentation
......@@ -1082,8 +1084,8 @@
;;; into non-standard unary predicates.
(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
long-float-p %string-char-p %standard-char-p structurep
array-header-p)
long-float-p base-char-p %string-char-p %standard-char-p structurep
array-header-p)
(t) boolean (movable foldable flushable))
......
......@@ -825,6 +825,8 @@
:argument-test #'types-intersect
:result-test #'values-types-intersect))
(setf (gethash node *failed-optimizations*) type)
t)
(t
t))))
......
......@@ -1468,7 +1468,7 @@
:name name
:type (specifier-type
(if (listp name)
`(function (,type ,slot-type) ,slot-type)
`(function (,slot-type ,type) ,slot-type)
`(function (,type) ,slot-type)))
:for info
:slot slot)))
......@@ -2416,7 +2416,7 @@
(unless (dsd-read-only slot)
(process-1-ftype-proclamation
`(setf ,fun)
(specifier-type `(function (,name ,type) ,type))))))
(specifier-type `(function (,type ,name) ,type))))))
(collect ((forms))
(when copier
......
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.19 1990/08/16 16:16:50 ram Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.20 1990/08/24 18:35:51 wlott Exp $
;;;
;;; This file contains the virtual machine independent parts of the code
;;; which does the actual translation of nodes to VOPs.
......@@ -202,7 +202,7 @@
(closure (environment-closure (lambda-environment leaf))))
(vop make-closure node block (emit-constant (length closure))
entry res)
(let ((n (1- system:%function-closure-variables-offset)))
(let ((n -1))
(dolist (what closure)
(vop closure-init node block
res (find-in-environment what this-env)
......@@ -1072,21 +1072,22 @@
;;;
(defun init-xep-environment (node block fun)
(declare (type bind node) (type ir2-block block) (type clambda fun))
(vop xep-allocate-frame node block (entry-info-offset (leaf-info fun)))
(let ((ef (functional-entry-function fun)))
(when (and (optional-dispatch-p ef)
(optional-dispatch-more-entry ef))
(vop copy-more-arg node block (optional-dispatch-max-args ef))))
(let ((env (environment-info (node-environment node))))
(let ((start-label (entry-info-offset (leaf-info fun)))
(env (environment-info (node-environment node))))
(vop xep-allocate-frame node block start-label)
(let ((ef (functional-entry-function fun)))
(when (and (optional-dispatch-p ef)
(optional-dispatch-more-entry ef))
(vop copy-more-arg node block (optional-dispatch-max-args ef))))
(if (ir2-environment-environment env)
(let ((closure (make-normal-tn *any-primitive-type*)))
(vop setup-closure-environment node block closure)
(let ((n (1- system:%function-closure-variables-offset)))
(vop setup-closure-environment node block start-label closure)
(let ((n -1))
(dolist (loc (ir2-environment-environment env))
(vop closure-ref node block closure (incf n) (cdr loc)))))
(vop setup-environment node block))
(vop setup-environment node block start-label))
(unless (eq (functional-kind fun) :top-level)
(let ((vars (lambda-vars fun))
(n 0))
......@@ -1104,7 +1105,7 @@
(emit-move node block (make-old-fp-passing-location t)
(ir2-environment-old-fp env)))
(undefined-value))
......@@ -1328,7 +1329,7 @@
(emit-constant name))))
;;;
(defoptimizer (%special-unbind ir2-convert) ((var) node block)
(vop unbind node block (emit-constant 1)))
(vop unbind node block))
;;; PROGV IR1 convert -- Internal
......@@ -1412,9 +1413,8 @@
;;;
;;; Emit code to set up a non-local-exit. Info is the NLX-Info for the
;;; exit, and Tag is the continuation for the catch tag (if any.) We get at
;;; the entry PC by making a :Label load-time constant TN. This is a
;;; non-immediate constant TN that is initialized to the offset of the
;;; specified label.
;;; the target PC by passing in the label to the vop. The vop is responsible
;;; for building a return-PC object.
;;;
(defun emit-nlx-start (node block info tag)
(declare (type node node) (type ir2-block block) (type nlx-info info)
......@@ -1424,11 +1424,8 @@
(block-tn (environment-live-tn
(make-normal-tn (primitive-type-or-lose 'catch-block))
(node-environment node)))
(res (make-normal-tn *any-primitive-type*))
(target-tn
(make-load-time-constant-tn
:label
(block-label (nlx-info-target info)))))
(res (make-stack-pointer-tn))
(target-label (ir2-nlx-info-target 2info)))
(vop* save-dynamic-state node block
(nil)
......@@ -1438,9 +1435,9 @@
(ecase kind
(:catch
(vop make-catch-block node block block-tn
(continuation-tn node block tag) target-tn res))
((:unwind-protect :block :tagbody)
(vop make-unwind-block node block block-tn target-tn res)))
(continuation-tn node block tag) target-label res))
((:unwind-protect :entry)
(vop make-unwind-block node block block-tn target-label res)))
(ecase kind
((:block :tagbody)
......@@ -1508,23 +1505,26 @@
(2info (nlx-info-info info))
(top-loc (ir2-nlx-info-save-sp 2info))
(start-loc (make-old-fp-passing-location t))
(count-loc (make-argument-count-location)))
(count-loc (make-argument-count-location))
(target (ir2-nlx-info-target 2info)))
(ecase (cleanup-kind (nlx-info-cleanup info))
((:catch :block :tagbody)
(if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
(vop* nlx-entry-multiple node block
(top-loc start-loc count-loc nil)
((reference-tn-list (ir2-continuation-locs 2cont) t)))
((reference-tn-list (ir2-continuation-locs 2cont) t))
target)
(let ((locs (standard-result-tns cont)))
(vop* nlx-entry node block
(top-loc start-loc count-loc nil)
((reference-tn-list locs t))
target
(length locs))
(move-continuation-result node block locs cont))))
(:unwind-protect
(let ((block-loc (standard-argument-location 0)))
(vop uwp-entry node block block-loc start-loc count-loc)
(vop uwp-entry node block target block-loc start-loc count-loc)
(move-continuation-result
node block
(list block-loc start-loc count-loc)
......@@ -1569,7 +1569,7 @@
(first res))
(move-continuation-result node block res cont)))
(defoptimizer (%slot-setter ir2-convert) ((str value) node block)
(defoptimizer (%slot-setter ir2-convert) ((value str) node block)
(let ((val (continuation-tn node block value)))
(vop structure-set node block
(continuation-tn node block str)
......
......@@ -165,7 +165,9 @@
(loop-analyze component)
|#
(let ((*compile-component* component))
(let ((*compile-component* component)
(*code-segment* nil)
(*elsewhere* nil))
(maybe-mumble "Env ")
(environment-analyze component)
(maybe-mumble "GTN ")
......@@ -216,22 +218,26 @@
(describe-component component *compiler-trace-output*))
(maybe-mumble "Code ")
(generate-code component))
(etypecase object
(fasl-file
(maybe-mumble "FASL")
(fasl-dump-component component *code-vector* *next-location*
*assembler-nodes* (1+ *current-assembler-node*)
*result-fixups* object))
(core-object
(maybe-mumble "Core"
(make-core-component component *code-vector* *next-location*
*assembler-nodes* (1+ *current-assembler-node*)
*result-fixups* object)))
(null))
(compiler-mumble "~%")
(let ((length (generate-code component)))
(when *compiler-trace-output*
(format *compiler-trace-output*
"~|~%Assembly code for ~S~2%"
component)
(dump-segment *code-segment* *compiler-trace-output*))
(etypecase object
(fasl-file
(maybe-mumble "FASL")
(fasl-dump-component component *code-segment* length object))
(core-object
(maybe-mumble "Core")
(make-core-component component *code-segment* length object))
(null))
(nuke-segment *code-segment*)))
(compiler-mumble "~&")
(undefined-value))
......@@ -716,7 +722,9 @@
(cond (*block-compile* (push tll *top-level-lambdas*))
(t
(compile-top-level (list tll) object)
(clear-stuff)))))
(clear-stuff))))
#+new-compiler
(lisp::maybe-gc))
;;; PROCESS-PROGN -- Internal
......@@ -1116,7 +1124,8 @@
(pathname file))))
(when output-file
(setq output-file-name (frob output-file "nfasl"))
(setq output-file-name
(frob output-file vm:target-fasl-file-type))
(setq fasl-file (open-fasl-file output-file-name
(namestring (first source)))))
......
......@@ -282,7 +282,7 @@
(setf (svref (sc-load-costs to-sc) num) ',cost)))))
(defun ,name ,lambda-list
(assemble (vop-node ,(first lambda-list))
(assemble (*code-segment* ,(first lambda-list))