source: branches/working-0711/ccl/compiler/nx.lisp @ 8917

;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of OpenMCL.  
;;;
;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with OpenMCL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")

(eval-when (:compile-toplevel)
  (require 'nxenv)
  (require 'numbers)
  (require 'sequences)
  (require 'optimizers))

(eval-when (:load-toplevel :execute :compile-toplevel)
  (require 'numbers) ; just calls 'logcount' and 'integer-length'
  (require 'sort)    ; just calls '%sort-list-no-keys'
  (require 'hash))

(%include "ccl:compiler;nx-basic.lisp")

(eval-when (:load-toplevel :execute)
  (require "DEFSTRUCT"))

(defparameter *nx-start* (cons nil nil))


(defvar *host-backend*)
(defvar *target-backend*)

(defun find-backend (name)
  (find name *known-backends* :key #'backend-name))

(eval-when (:load-toplevel :execute :compile-toplevel)
  (require "DLL-NODE")
  #+ppc-target
  (require "PPC32-ARCH")
  (require "VREG")
  #+ppc-target
  (require "PPC-ASM")
  (require "VINSN")
  (require "REG")
  (require "SUBPRIMS")
  #+ppc-target
  (require "PPC-LAP")
)
(%include "ccl:compiler;nx0.lisp")
(%include "ccl:compiler;nx1.lisp")

; put this in nx-basic too
;(defvar *lisp-compiler-version* 666 "I lost count.")

; At some point, COMPILE refused to compile things that were defined
; in a non-null lexical environment (or so I remember.)   That seems
; to have been broken when the change of 10/11/93 was made.
; It makes no sense to talk about compiling something that was defined
; in a lexical environment in which there are symbol or function bindings
; present;  I'd thought that the old code checked for this, though it
; may well have botched it.
(defun compile (spec &optional def &aux (macro-p nil))
  "Coerce DEFINITION (by default, the function whose name is NAME)
  to a compiled function, returning (VALUES THING WARNINGS-P FAILURE-P),
  where if NAME is NIL, THING is the result of compilation, and
  otherwise THING is NAME. When NAME is not NIL, the compiled function
  is also set into (MACRO-FUNCTION NAME) if NAME names a macro, or into
  (FDEFINITION NAME) otherwise."
  (unless def
    (setq def (fboundp spec))
    (when (and (symbolp spec) (not (lfunp def)))
      (setq def (setq macro-p (macro-function spec)))))
  #+have-interpreted-functions
  (when (typep def 'interpreted-function)
    (let ((lambda (function-lambda-expression def)))
      (when lambda (setq def lambda))))
  (unless def
    (nx-error "Can't find compilable definition for ~S." spec))
  (multiple-value-bind (lfun warnings)
                       (if (functionp def)
                         def
                         (compile-named-function def
                                                 :name spec
                                                 :keep-lambda *save-definitions*
                                                 :keep-symbols *save-local-symbols*))
    (let ((harsh nil) (some nil) (init t))
      (dolist (w warnings)
        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
        (setq init nil))
      (values
       (if spec
         (progn
           (if macro-p
             (setf (macro-function spec) lfun)
             (setf (fdefinition spec) lfun))
           spec)
         lfun)
       some
       harsh))))

(defparameter *default-compiler-policy* (new-compiler-policy))

(defun current-compiler-policy () *default-compiler-policy*)

(defun set-current-compiler-policy (&optional new-policy)
  (setq *default-compiler-policy* 
        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))

#+ppc-target
(defun xcompile-lambda (target def)
  (let* ((*ppc2-debug-mask* (ash 1 ppc2-debug-vinsns-bit))
         (backend (find-backend target))
         (*target-ftd* (if backend
                         (backend-target-foreign-type-data backend)
                         *target-ftd*))
         (*target-backend* (or backend *target-backend*)))
    (multiple-value-bind (xlfun warnings)
        (compile-named-function def :target target)
      (signal-or-defer-warnings warnings nil)
      (ppc-xdisassemble xlfun :target target)
      xlfun)))

(defun signal-or-defer-warnings (warnings env)
  (let* ((defenv (definition-environment env))
         (init t)
         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
    (dolist (w warnings)
      (if (and defer (typep w 'undefined-function-reference))
        (push w (deferred-warnings.warnings defer))
        (progn
          (signal-compiler-warning w init nil nil nil)
          (setq init nil))))))

(defparameter *load-time-eval-token* nil)
(defparameter *nx-source-note-map* nil)

(defun note-contained-in-p (note parent)
  (loop for n = note then (code-note-source n) while (code-note-p n) thereis (eq n parent)))

(defun nx-find-code-note (form)
  ;; Try to find a source note for this form.  The act of matching up a source note with
  ;; forms that might come from macroexpansion is heuristic at best.  In general, err in
  ;; favor of not matching, because that leads to fewer false positives in code coverage
  ;; reporting.
  (when (or (consp form) (stringp form) (pathnamep form))
    (let ((note (gethash form *nx-source-note-map*)))
      (unless (listp note)
        note))))

(defun nx-ensure-code-note (form original parent-note)
  ;; Try to find a source note for this form; if can't, just make a new record for it.
  (let* ((source-note (or (and original (nx-find-code-note original))
                          (nx-find-code-note form)))
         (note (if (and source-note
                        ;; Look out for a case like a lambda macro that turns (lambda ...)
                        ;; into (FUNCTION (lambda ...)) which then has (lambda ...)
                        ;; as a child.  Create a fresh note for the child, to avoid ambiguity.
                        ;; Another case is forms wrapping THE around themselves.
                        (neq source-note parent-note)
                        ;; Don't use source notes from a different toplevel form, which could
                        ;; happen due to inlining etc.  The result then is that the source note
                        ;; appears in multiple places, and shows partial coverage (from the
                        ;; other reference) in code that's never executed.
                        (loop for p = parent-note then (code-note-parent-note p)
                              when (null p) return t
                              when (source-note-p p)
                              return (let ((n source-note))
                                       (loop as s = (code-note-source p)
                                             while (source-note-p s) do (setq p s))
                                       (loop as s = (code-note-source n)
                                             while (source-note-p s) do (setq n s))
                                       (eq n p))))
                 source-note
                 (make-code-note :form (or original form) :source parent-note))))
    (register-code-note-parent note parent-note)
    note))

(eval-when (:compile-toplevel)
  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))

(defparameter *nx-discard-xref-info-hook* nil)

(defun compile-named-function (definition &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
  (when (and name *nx-discard-xref-info-hook*)
    (funcall *nx-discard-xref-info-hook* name))
  (setq 
   definition
   (let* ((*load-time-eval-token* load-time-eval-token)
          (*nx-source-note-map* source-notes)
          (*nx1-source-note-map* (and *fasl-save-source-locations* *nx-source-note-map*))
          (*nx-current-code-note* (and source-notes
                                       *compile-code-coverage*
                                       (nx-ensure-code-note definition nil function-note)))
          (*definition-source-note* (and *fasl-save-source-locations*
                                         (or function-note
                                             (and *form-source-note-map* (gethash definition *form-source-note-map*)))))
          (env (new-lexical-environment env)))
     (setf (lexenv.variables env) 'barrier)
       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
              (afunc (nx1-compile-lambda 
                      name 
                      definition 
                      (make-afunc) 
                      nil 
                      env 
                      (or policy *default-compiler-policy*)
                      *load-time-eval-token*)))
         (if (afunc-lfun afunc)
             afunc
             (funcall (backend-p2-compile *target-backend*)
                      afunc
                      ;; will also bind *nx-lexical-environment*
                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
                      keep-symbols)))))
  (values (afunc-lfun definition) (afunc-warnings definition)))
  
(defun compile-user-function (def name &optional env)
  (multiple-value-bind (lfun warnings)
      (compile-named-function def
                              :name name
                              :env env
                              :keep-lambda *save-definitions*
                              :keep-symbols *save-local-symbols*)
    (signal-or-defer-warnings warnings env)
    lfun))

(defparameter *compiler-whining-conditions*
  '((:undefined-function . undefined-function-reference)
    (:global-mismatch . invalid-arguments-global)
    (:lexical-mismatch . invalid-arguments)
    (:environment-mismatch . invalid-arguments)
    (:ignore . style-warning)
    (:result-ignored . style-warning)
    (:unused . style-warning)))



(defun compiler-bug (format &rest args)
  (error (make-condition 'compiler-bug
                         :format-control format
                         :format-arguments args)))


(defparameter *nx-end* (cons nil nil))
(provide 'nx)

(defun define-compile-time-macro (name lambda-expression env)
  (let ((definition-env (definition-environment env)))
    (when definition-env
      (push (list* name 
                   'macro 
                   (compile-named-function lambda-expression :name name :env env)) 
            (defenv.functions definition-env))
      (record-function-info name (cons nil 'macro) env))
    name))