Changeset 13891


Ignore:
Timestamp:
Jun 25, 2010, 11:28:56 PM (9 years ago)
Author:
gz
Message:

Add DECOMP-ACODE, decompile acode into something more readable.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r13675 r13891  
    707707      (cdr (assq name (defenv.structrefs defenv))))))
    708708
     709;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     710;;
     711;; decomp-acode
     712;;
     713;;  Decompile acode into something more readable.
     714;;  For debugging, but also used for a code coverage feature
     715
     716
     717(defun decomp-acode (acode)
     718  (cond ((eq acode *nx-t*) t)
     719        ((eq acode *nx-nil*) nil)
     720        (t (let* ((op (car acode))
     721                  (num (length *next-nx-operators*))
     722                  (name (when (and (fixnump op)
     723                                   (<= 0 op)
     724                                   (setq op (logand op operator-id-mask))
     725                                   (< op num))
     726                          (car (nth (- num op 1) *next-nx-operators*)))))
     727             (decomp-using-name (or name op) (cdr acode))))))
     728
     729;; TBD maybe decomp afunc-acode?
     730(defun decomp-afunc (afunc)
     731  (require-type afunc 'afunc))
     732
     733(defun decomp-var (var)
     734  (var-name (require-type var 'var)))
     735
     736(defun decomp-formlist (formlist)
     737  (mapcar #'decomp-acode formlist))
     738
     739(defun decomp-arglist (arglist)
     740  (destructuring-bind (stack-forms register-forms) arglist
     741    (nconc (decomp-formlist stack-forms)
     742           (nreverse (decomp-formlist register-forms)))))
     743
     744(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
     745  (flet ((decomp-arg (var)
     746           (if (acode-p var)
     747             (destructuring-bind (op whole req opt rest keys auxen) var
     748               (assert (eq op (%nx1-operator lambda-list))) ;; fake
     749               (decomp-lambda-list req opt rest keys auxen whole))
     750             (decomp-var var))))
     751    (let ((whole (and whole (list '&whole (decomp-arg whole))))
     752          (reqs (mapcar #'decomp-arg req))
     753          (opts (when opt (cons '&optional (apply #'mapcar
     754                                                  (lambda (var init supp)
     755                                                    (list (decomp-arg var)
     756                                                          (decomp-acode init)
     757                                                          (and supp (decomp-arg supp))))
     758                                                  opt))))
     759          (rest (when rest (list '&rest (decomp-arg rest))))
     760          (keys (when keys
     761                  (destructuring-bind (aok vars supps inits keyvect) keys
     762                    (nconc
     763                     (when vars
     764                       (cons '&key (map 'list (lambda (var supp init key)
     765                                                (list* (list key (decomp-arg var))
     766                                                       (decomp-acode init)
     767                                                       (and supp (list (decomp-arg supp)))))
     768                                        vars supps inits keyvect)))
     769                     (when aok (list '&allow-other-keys))))))
     770          (auxen (when (car auxen)
     771                   (cons '&aux (apply #'mapcar
     772                                      (lambda (var init)
     773                                        (list (decomp-arg var) (decomp-acode init)))
     774                                      auxen)))))
     775      (nconc whole reqs opts rest keys auxen))))
     776
     777(defmacro defdecomp (names arglist &body body)
     778  (let ((op-var (car arglist))
     779        (args-vars (cdr arglist))
     780        (op-decls nil)
     781        (args-var (gensym)))
     782    (multiple-value-bind (body decls) (parse-body body nil)
     783    ;; Kludge but good enuff for here
     784      (setq decls (loop for decl in decls
     785                    collect (cons (car decl)
     786                                  (loop for exp in (cdr decl)
     787                                    do (when (and (consp exp) (member op-var (cdr exp)))
     788                                         (push (list (car exp) op-var) op-decls))
     789                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
     790    `(progn
     791       ,@(loop for name in (if (atom names) (list names) names)
     792           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
     793                      (declare ,@op-decls)
     794                      (destructuring-bind ,args-vars ,args-var
     795                        ,@decls
     796                        ,@body)))))))
     797
     798;; Default method
     799(defmethod decomp-using-name (op forms)
     800  `(,op ,@(decomp-formlist forms)))
     801
     802;; not real op, kludge generated below for lambda-bind
     803(defdecomp keyref (op index)
     804  `(,op ,index))
     805
     806(defdecomp immediate (op imm)
     807  (declare (ignore op))
     808  `',imm)
     809
     810(defdecomp fixnum (op raw-fixnum)
     811  (declare (ignore op))
     812  raw-fixnum)
     813
     814(defdecomp %function (op symbol)
     815  (declare (ignore op))
     816  `(function ,symbol))
     817
     818(defdecomp simple-function (op afunc)
     819  (declare (ignore op))
     820  `(quote ,(decomp-afunc afunc)))
     821
     822(defdecomp closed-function (op afunc)
     823  `(,op ,(decomp-afunc afunc)))
     824
     825(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
     826  `(,op ,@(decomp-formlist form-list)))
     827
     828(defdecomp multiple-value-call (op fn form-list)
     829  `(,op ,(decomp-acode fn) ,@(decomp-formlist form-list)))
     830
     831(defdecomp vector (op formlist)
     832  `(,op ,@(decomp-formlist formlist)))
     833
     834(defdecomp (%gvector list* %err-disp) (op arglist)
     835  `(,op ,@(decomp-arglist arglist)))
     836
     837(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
     838            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
     839           (op target argspecs argvals resultspec &rest rest)
     840  `(,op
     841    ,(decomp-acode target)
     842    ,@(mapcan (lambda (spec val) (list spec (decomp-acode val))) argspecs argvals)
     843    ,resultspec
     844    ,@rest))
     845
     846(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
     847  (if (eq (acode-immediate-operand cc) :eq)
     848    `(,op ,@(decomp-formlist forms))
     849    `(,op ,(decomp-acode cc) ,@(decomp-formlist forms))))
     850
     851(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
     852  `(,op ',typespec ,(decomp-acode form) ,check-p))
     853
     854(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
     855  `(,op ,(decomp-acode form1) ,(decomp-acode form2) ,overflow-p))
     856
     857(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
     858  `(,op ,bits ,@(decomp-formlist forms)))
     859
     860(defdecomp call (op fn arglist &optional spread-p)
     861  (declare (Ignore op))
     862  `(,(if spread-p 'apply 'funcall) ,(decomp-acode fn) ,@(decomp-arglist arglist)))
     863
     864(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
     865  (declare (Ignore op))
     866  `(,(if spread-p 'apply 'funcall) ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
     867
     868(defdecomp self-call (op arglist &optional spread-p)
     869  (declare (Ignore op))
     870  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))
     871
     872(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
     873  `(,op ,symbol))
     874
     875(defdecomp (setq-special setq-free global-setq) (op symbol form)
     876  `(,op ,symbol ,(decomp-acode form)))
     877
     878(defdecomp (inherited-arg lexical-reference setq-lexical) (op var &rest forms)
     879  `(,op ,(decomp-var var) ,@(decomp-formlist forms)))
     880
     881
     882(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
     883  (declare (ignore p2decls))
     884  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-acode val))) vars vals)
     885    ,(decomp-acode body)))
     886
     887(defdecomp %decls-body (op form p2decls)
     888  (declare (ignore p2decls))
     889  `(,op ,(decomp-acode form)))
     890
     891(defdecomp multiple-value-bind (op vars form body p2decls)
     892  (declare (ignore p2decls))
     893  `(,op ,(mapcar #'decomp-var vars) ,(decomp-acode form) ,(decomp-acode body)))
     894
     895
     896(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
     897  (declare (ignore p2decls code-note))
     898  `(lambda-list ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-acode body)))
     899
     900(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
     901  (declare (ignore ll p2decls cdr-p))
     902  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-acode form) ,(decomp-acode body)))
     903
     904(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
     905  (declare (ignore keys-p p2decls))
     906  (when (find-if #'fixnump (cadr auxen))
     907    (destructuring-bind (vars vals) auxen
     908      (setq auxen (list vars
     909                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
     910  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
     911    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-acode body))))
     912
     913(defdecomp (flet labels) (op vars afuncs body p2decls)
     914  (declare (ignore p2decls))
     915  `(,op ,(mapcar (lambda (var afunc)
     916                            (list (decomp-var var) (decomp-afunc afunc)))
     917                          vars afuncs)
     918    ,(decomp-acode body)))
     919
     920(defdecomp local-go (op tag)
     921  `(,op ,(car tag)))
     922
     923(defdecomp tag-label (op &rest tag)
     924  `(,op ,(car tag)))
     925
     926(defdecomp local-tagbody (op tags forms)
     927  (declare (ignore tags))
     928  `(,op ,@(decomp-formlist forms)))
     929
     930(defdecomp local-block (op block body)
     931  `(,op ,(car block) ,(decomp-acode body)))
     932
     933(defdecomp local-return-from (op block form)
     934  `(,op ,(car block) ,(decomp-acode form)))
     935
    709936; end
Note: See TracChangeset for help on using the changeset viewer.