home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / function-info.lisp < prev    next >
Encoding:
Text File  |  1992-09-11  |  7.9 KB  |  239 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defmacro define-compiler-method ((name new-function) in/out
  4.                   &optional (transform '#'identity))
  5.   (multiple-value-bind (ins outs in-types out-types)
  6.       (parse-in/out in/out)
  7.     `(add-compiler-method ',name ',ins ',outs
  8.       ',in-types ',out-types ',new-function ,transform)))
  9.  
  10. (defmacro define-meta-eval (function-spec arg-types)
  11.   `(add-meta-eval-method ',function-spec ',arg-types))
  12.  
  13. (defun add-meta-eval-method (function-spec arg-types)
  14.   (multiple-value-bind (function-name meta-eval-function)
  15.       (if (listp function-spec)
  16.       (values (first function-spec) (second function-spec))
  17.       (values function-spec function-spec))
  18.     (let ((info (get-or-create-proc-info function-name)))
  19.       (setf (function-info-meta-eval-function info) meta-eval-function)
  20.       (setf (function-info-meta-eval-arg-types info) arg-types)
  21.       function-name)))
  22.  
  23. (defun add-compiler-method (name ins outs in-types out-types
  24.                  new-function transform)
  25.   (let ((info (get-or-create-proc-info name)))
  26.     (loop for method in (function-and-method-info-methods info)
  27.       when (and (equal (compiler-method-in-types method) in-types)
  28.             (equal (compiler-method-out-types method) out-types))
  29.       do (return (setf (function-and-method-info-methods info)
  30.                (delete method
  31.                    (function-and-method-info-methods info)
  32.                    :test #'eq))))
  33.     (push (make-compiler-method :name name
  34.                 :ins ins
  35.                 :outs outs
  36.                 :in-types in-types
  37.                 :out-types out-types
  38.                 :new-function new-function
  39.                 :transform transform)
  40.       (function-and-method-info-methods info))
  41.     name))
  42.  
  43. (defun get-proc-info (name)
  44.   (initialize-function-info-table)
  45.   (or (and (not (null *new-function-info*))
  46.        (gethash name *new-function-info*))
  47.       (gethash name *primary-function-info*)))
  48.  
  49. (defun new-function-info-table (&optional (size 3000))
  50.   (make-hash-table :size size))
  51.  
  52. (defun initialize-function-info-table ()
  53.   (when (null *primary-function-info*)
  54.     (setf *primary-function-info* (new-function-info-table 5000))))
  55.  
  56. (defun get-or-create-proc-info (name)
  57.   (let ((info (or (get-proc-info name)
  58.           (setf (gethash name *primary-function-info*)
  59.             (make-proc-info :name name)))))
  60.     (unless (null *new-function-info*)
  61.       (setf (gethash name *new-function-info*) info))
  62.     info))
  63.  
  64. (defun add-proc-definition (name body function source)
  65.   (declare (ignore source))
  66.   (let ((entry (get-or-create-proc-info name)))
  67.     (unless (foreign-info-p entry)    ; Ignore Lisp def of foreign funcs
  68.       (delete-undefined-function name)
  69.       (setf (proc-info-defined? entry) t)
  70.       (destructuring-bind (lambda lambda-list . actual-body) (third function)
  71.     (declare (ignore lambda actual-body))
  72.     (when (proc-info-inline? entry)
  73.       (setf (proc-info-lambda-expr entry)
  74.         `(lambda ,lambda-list ,@body)))
  75.     (setf (proc-info-ins entry) lambda-list)
  76.     (setf (proc-info-source-file entry) nil)))) ; save some space
  77.   name)
  78.  
  79. (defun proclaim-ftype-info (name in-types out-types)
  80.   (let ((entry (get-or-create-proc-info name)))
  81.     (setf (proc-info-in-types entry) in-types)
  82.     (setf (proc-info-out-types entry) out-types)
  83.     name))
  84.  
  85. (defun proclaim-inline-function (name)
  86.   (setf (proc-info-inline? (get-or-create-proc-info name)) t)
  87.   name)
  88.  
  89. (defun proclaim-notinline-function (name)
  90.   (setf (proc-info-inline? (get-or-create-proc-info name)) nil)
  91.   name)
  92.  
  93.               
  94. (defun delete-proc-info (name)
  95.   (remhash name *primary-function-info*)
  96.   (unless (null *new-function-info*) 
  97.     (remhash name *new-function-info*)))
  98.  
  99. (defun validate-function-call (call)
  100.   call)
  101.  
  102. (defun add-undefined-function (name caller)
  103.   (push (gethash name *undefined-functions*) caller))
  104.  
  105. (defun delete-undefined-function (name)
  106.   (remhash name *undefined-functions*))
  107.  
  108. (defun add-function-call-info (caller callee)
  109.   caller callee
  110.   nil)
  111.  
  112. (defun clear-undefined-functions ()
  113.   (clrhash *undefined-functions*))
  114.  
  115. (defun list-undefined-functions ()
  116.   (maphash #'(lambda (function callers)
  117.            (format t "~A was called by ~{~A ~}~%"  function callers))
  118.        *undefined-functions*))
  119.  
  120. (defun write-procedure-info (procedure-info output)
  121.   (let ((*package* *compiler-package*)
  122.     (*print-circle* nil)
  123.     (*print-array* t)
  124.     (*print-structure* t))
  125.     (maphash #'(lambda (key value)
  126.          (typecase value
  127.            (proc-info
  128.             (format output ":pinfo ~S ~S ~S ~S ~S ~S ~S ~S ~S~%"
  129.                 key
  130.                 (proc-info-ins value)
  131.                 (proc-info-outs value)
  132.                 (proc-info-in-types value)
  133.                 (proc-info-out-types value)
  134.                 (proc-info-lambda-expr value)
  135.                 (proc-info-source-file value)
  136.                 (proc-info-inline? value)
  137.                 (proc-info-defined? value)))
  138.            (foreign-info
  139.             (format output ":finfo ~S ~S ~S ~S ~S ~S~%"
  140.                 (foreign-info-name value)
  141.                 (foreign-info-foreign-name value)
  142.                 (foreign-info-ins value)
  143.                 (foreign-info-outs value)
  144.                 (foreign-info-in-types value)
  145.                 (foreign-info-out-types value)))))
  146.          procedure-info)))
  147.  
  148. (defun write-c-type-info (c-type-info output) 
  149.   (let ((*package* *compiler-package*)
  150.     (*print-circle* nil)
  151.     (*print-array* t)
  152.     (*print-structure* t))
  153.     ;; Have to write structure defs out first
  154.     (maphash #'(lambda (name type)
  155.          (when (c-struct-info-p type)
  156.            (format output ":c-type ~S ~S~%" name type)))
  157.          c-type-info)
  158.     ;; Then write all other named types
  159.     (maphash #'(lambda (name type)
  160.          (unless (c-struct-info-p type)
  161.            (format output ":c-type ~S ~S~%" name type)))
  162.          c-type-info)))
  163.  
  164. (defun read-procedure-info (input)
  165.   (let ((*package* *compiler-package*))
  166.     (dotimes (i (read input t))
  167.       (let ((type (read input t))
  168.         (name (read input t)))
  169.     (ecase type
  170.       (:pinfo (setf (gethash name *primary-function-info*)
  171.             (read-procedure-info-line
  172.              (get-or-create-proc-info name)
  173.              input)))
  174.       (:finfo (setf (gethash name *primary-function-info*)
  175.             (read-foreign-info-line (make-foreign-info :name name)
  176.                         input)))
  177.       (:c-type (let ((type (read input t)))
  178.              (if (c-struct-info-p type)
  179.              (define-c-structure type)
  180.              (define-c-type-name name type)))))))))
  181.  
  182.  
  183. (defun read-procedure-info-line (info input)
  184.   (let ((*package* *compiler-package*))
  185.     (setf (proc-info-ins info) (read input t))
  186.     (setf (proc-info-outs info) (read input t))
  187.     (setf (proc-info-in-types info) (read input t))
  188.     (setf (proc-info-out-types info) (read input t))
  189.     (setf (proc-info-lambda-expr info) (read input t))
  190.     (setf (proc-info-source-file info) (read input t))
  191.     (setf (proc-info-inline? info) (read input t))
  192.     (setf (proc-info-defined? info) (read input t))
  193.     info))
  194.  
  195. (defun read-foreign-info-line (info input)
  196.   (let ((*package* *compiler-package*))
  197.     (setf (foreign-info-foreign-name info) (read input t))
  198.     (setf (foreign-info-ins info) (read input t))
  199.     (setf (foreign-info-outs info) (read input t))
  200.     (let ((in-types (read input t))
  201.       (out-types (read input t)))
  202.       (setf (foreign-info-in-types info) in-types) 
  203.       (setf (foreign-info-out-types info) out-types)
  204.       (setf (foreign-info-in-type-objects info)
  205.         (mapcar #'c-type-name->c-type-object in-types))
  206.       (setf (foreign-info-out-type-objects info)
  207.         (mapcar #'c-type-name->c-type-object out-types))
  208.       info)))
  209.  
  210. (defun define-foreign-function (name foreign-name ins outs in-types
  211.                      out-types)
  212.   (let ((old-info (get-proc-info name)))
  213.     (setf (gethash name *primary-function-info*)
  214.       (make-foreign-info
  215.        :name name
  216.        :foreign-name foreign-name
  217.        :ins ins
  218.        :outs outs
  219.        :in-types in-types
  220.        :out-types out-types
  221.        :in-type-objects (mapcar #'c-type-name->c-type-object in-types)
  222.        :out-type-objects (mapcar #'c-type-name->c-type-object out-types)
  223.        ;; Be sure to preserve method info!
  224.        :methods (if (null old-info)
  225.             nil
  226.             (function-and-method-info-methods old-info)))))
  227.   name)
  228.  
  229. (defun define-primitive (name ins outs in-types out-types emitter)
  230.   (setf (gethash name *primary-function-info*)
  231.     (make-primitive-info
  232.      :name name
  233.      :ins ins
  234.      :outs outs
  235.      :in-types in-types
  236.      :out-types out-types
  237.      :emitter emitter))
  238.   name)
  239.