/[cmucl]/src/code/pmax-disassem.lisp
ViewVC logotype

Diff of /src/code/pmax-disassem.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by wlott, Wed Nov 7 13:15:26 1990 UTC revision 1.14 by wlott, Sat Nov 17 05:43:08 1990 UTC
# Line 52  Line 52 
52    
53  ;;;; Register Names  ;;;; Register Names
54    
 (defparameter register-name-style :lisp  
   "The register name style: :c, :lisp, :raw")  
   
 (defvar *c-register-names*  
   '#("ZERO" "$AT" "$V0" "$V1" "$A0" "$A1" "$A2" "$A3"  
      "$T0" "$T1" "$T2" "$T3" "$T4" "$T5" "$T6" "$T7"  
      "$S0" "$S1" "$S2" "$S3" "$S4" "$S5" "$S6" "$S7"  
      "$T8" "$T9" "$K0" "$K1" "$GP" "$SP" "$S8" "$RA"))  
   
 (defvar *lisp-register-names*  
   '#("$ZERO" "$LIP" "$NL0" "$NL1" "$NL2" "$NL3" "$NL4" "$NARGS"  
      "$A0" "$A1" "$A2" "$A3" "$A4" "$A5" "$CNAME" "$LEXENV"  
      "$ARGS" "$OLDCONT" "$LRA" "$L0" "$NULL" "$BSP" "$CONT" "$CSP"  
      "$FLAGS" "$ALLOC" "$K0" "$K1" "$L1" "$NSP" "$CODE" "$L2"))  
   
 (defvar *raw-register-names*  
   '#("$R0" "$R1" "$R2" "$R3" "$R4" "$R5" "$R6" "$R7"  
      "$R8" "$R9" "$R10" "$R12" "$R13" "$R14" "$R15"  
      "$R16" "$R17" "$R18" "$R19" "$R20" "$R21" "$R22" "$R23"  
      "$R24" "$R25" "$R26" "$R27" "$R28" "$R29" "$R30" "$R31"))  
   
55  (defun register-name (register-number)  (defun register-name (register-number)
56    (unless (<= 0 register-number 31)    (unless (<= 0 register-number 31)
57      (error "Illegal register number!"))      (error "Illegal register number!"))
58    (let ((register-names (ecase register-name-style    (svref *register-names* register-number))
59                            (:c *c-register-names*)  
                           (:lisp *lisp-register-names*)  
                           (:raw *raw-register-names*))))  
     (svref register-names register-number)))  
60    
61    
62  ;;;; Instruction Type Definition  ;;;; Instruction Type Definition
# Line 471  Line 447 
447               (setf instruction-in-delay-slot-p t))               (setf instruction-in-delay-slot-p t))
448              (t              (t
449               (setf instruction-in-delay-slot-p nil))))))               (setf instruction-in-delay-slot-p nil))))))
450    
451    
452    
453    ;;;; Disassemble-code-sap
454    
455    (defun disassemble-code-sap (sap length &optional (stream t))
456      (do ((*current-instruction-number* 0 (1+ *current-instruction-number*))
457           (instruction-in-delay-slot-p nil))
458          ((>= *current-instruction-number* length))
459        (unless instruction-in-delay-slot-p
460          (format stream "~6D:" *current-instruction-number*))
461        (multiple-value-bind
462            (name type)
463            (disassemble-instruction (system:sap-ref-32
464                                      sap
465                                      *current-instruction-number*)
466                                     stream)
467          (declare (ignore name))
468          (cond ((member type delay-slot-instruction-types :test #'eq)
469                 (setf instruction-in-delay-slot-p t))
470                (t
471                 (setf instruction-in-delay-slot-p nil))))))
472    
473    
474    ;;;; Disassemble
475    
476    (defun compile-function-lambda-expr (function)
477      (multiple-value-bind
478          (lambda closurep name)
479          (function-lambda-expression function)
480        (declare (ignore name))
481        (when closurep
482          (error "Cannot compile lexical closure."))
483        (compile nil lambda)))
484    
485    (defun disassemble (object &optional (stream *standard-output*))
486      (let* ((function (cond ((or (symbolp object)
487                                  (and (listp object)
488                                       (eq (car object) 'lisp:setf)))
489                              (let ((temp (fdefinition object)))
490                                (if (eval:interpreted-function-p temp)
491                                    (compile-function-lambda-expr temp)
492                                    temp)))
493                             ((eval:interpreted-function-p object)
494                              (compile-function-lambda-expr object))
495                             ((functionp object)
496                              object)
497                             ((and (listp object)
498                                   (eq (car object) 'lisp::lambda))
499                              (compile nil object))
500                             (t
501                              (error "Invalid argument to disassemble - ~S"
502                                     object))))
503             (self (system:%primitive function-self function))
504             (code (di::function-code-header self)))
505        (disassemble-code-sap (truly-the system:system-area-pointer
506                                         (system:%primitive code-instructions
507                                                            code))
508                              (system:%primitive code-code-size code)
509                              stream)))

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

  ViewVC Help
Powered by ViewVC 1.1.5