/src/cmp/cmplam.lsp

;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

;;;;
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

;;;; CMPLAM  Lambda expression.

(in-package "COMPILER")

;;; During Pass1, a lambda-list
;;;
;;; (   { var }*
;;;     [ &optional { var | ( var [ initform [ svar ] ] ) }* ]
;;;     [ &rest var ]
;;;     [ &key { var | ( { var | ( kwd var ) } [initform [ svar ]])}*
;;;             [&allow-other-keys]]
;;;     [ &aux {var | (var [initform])}*]
;;; )
;;;
;;; is transformed into
;;;
;;; (   ( { var }* )                            ; required
;;;     ( { var initform svar }* )              ; optional
;;;     { var | nil }                           ; rest
;;;     allow-other-keys-flag
;;;     ( { kwd-vv-index var initform svar }* ) ; key
;;; )
;;;
;;; where
;;;     svar:   NIL     ; means svar is not supplied
;;;             | var
;;;
;;; &aux parameters will be embedded into LET*.
;;;
;;; c1lambda-expr receives
;;;     ( lambda-list { doc | decl }* . body )
;;; and returns
;;;     ( lambda info-object lambda-list' doc body' )
;;;
;;; Doc is NIL if no doc string is supplied.
;;; Body' is body possibly surrounded by a LET* (if &aux parameters are
;;; supplied) and an implicit block.

(defun c1lambda-doc (form)
  (second (c1form-args form)))

(defun c1lambda-body (form)
  (third (c1form-args form)))

(defun c1lambda-list (form)
  (first (c1form-args form)))

(defun fun-needs-narg (fun)
  (not (fun-fixed-narg fun)))

(defun fun-fixed-narg (fun)
  "Returns true if the function has a fixed number of arguments and it is not a closure.
The function thus belongs to the type of functions that ecl_make_cfun accepts."
  (let (narg)
    (and (not (eq (fun-closure fun) 'CLOSURE))
         (= (fun-minarg fun) (setf narg (fun-maxarg fun)))
         (<= narg si::c-arguments-limit)
         narg)))

(defun add-to-fun-referenced-vars (fun var-list)
  (loop with new-vars = (fun-referenced-vars fun)
     with locals = (fun-local-vars fun)
     with change = nil
     for v in var-list
     when (and (not (member v locals :test #'eq))
               (not (member v new-vars :test #'eq)))
     do (setf change t new-vars (cons v new-vars))
     finally (when change
               (setf (fun-referenced-vars fun) new-vars)
               (return t))))

(defun add-to-fun-referenced-funs (fun fun-list)
  (loop with new-funs = (fun-referenced-funs fun)
     with change = nil
     for f in fun-list
     when (and (not (eq fun f))
               (not (member f new-funs :test #'eq))
               (not (child-function-p fun f)))
     do (setf change t
              new-funs (cons f new-funs)
              (fun-referencing-funs f) (cons fun (fun-referencing-funs f)))
     finally (when change
               (setf (fun-referenced-funs fun) new-funs)
               (return t))))

(defun c1compile-function (lambda-list-and-body &key (fun (make-fun))
                           (name (fun-name fun)) (CB/LB 'CB))
  (let ((lambda (if name
                    `(ext:lambda-block ,name ,@lambda-list-and-body)
                    `(lambda ,@lambda-list-and-body))))
    (setf (fun-name fun) name
          (fun-lambda-expression fun) lambda 
          (fun-parent fun) *current-function*))
  (when *current-function*
    (push fun (fun-child-funs *current-function*)))
  (let* ((*current-function* fun)
         (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB)))
         (setjmps *setjmps*)
         (decl (si::process-declarations (rest lambda-list-and-body)))
         (global (and *use-c-global*
                      (assoc 'SI::C-GLOBAL decl)
                      (setf (fun-global fun) T)))
         (no-entry (assoc 'SI::C-LOCAL decl))
         (lambda-expr (c1lambda-expr lambda-list-and-body
                                     name
                                     (si::function-block-name name)))
         cfun exported minarg maxarg)
    (when (and no-entry (policy-debug-ihs-frame))
      (setf no-entry nil)
      (cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name))
    (unless (eql setjmps *setjmps*)
      (setf (c1form-volatile lambda-expr) t))
    (setf (fun-lambda fun) lambda-expr)
    (if global
        (multiple-value-setq (cfun exported) (exported-fname name))
        (setf cfun (next-cfun "LC~D~A" name) exported nil))
    #+ecl-min
    (when (member name c::*in-all-symbols-functions*)
      (setf no-entry t))
    (if exported
        ;; Check whether the function was proclaimed to have a certain
        ;; number of arguments, and otherwise produce a function with
        ;; a flexible signature.
        (progn
          (multiple-value-setq (minarg maxarg) (get-proclaimed-narg name))
          (format t "~&;;; Function ~A proclaimed (~A,~A)" name minarg maxarg)
          (unless minarg
            (setf minarg 0 maxarg call-arguments-limit)))
        (multiple-value-setq (minarg maxarg)
          (lambda-form-allowed-nargs lambda-expr)))
    (setf (fun-cfun fun) cfun
          (fun-exported fun) exported
          (fun-closure fun) nil
          (fun-minarg fun) minarg
          (fun-maxarg fun) maxarg
          (fun-description fun) name
          (fun-no-entry fun) no-entry)
    (loop for child in (fun-child-funs fun)
       do (add-to-fun-referenced-vars fun (fun-referenced-vars child))
       do (add-to-fun-referenced-funs fun (fun-referenced-funs child)))
    (loop for f in (fun-referenced-funs fun)
       do (add-to-fun-referenced-vars fun (fun-referenced-vars f)))
    (update-fun-closure-type fun)
    (when global
      (if (fun-closure fun)
          (cmpnote "Function ~A is global but is closed over some variables.~%~{~A ~}"
                   (fun-name fun) (mapcar #'var-name (fun-referenced-vars fun)))
          (new-defun fun (fun-no-entry fun)))))
  fun)

(defun cmp-process-lambda-list (list)
  (handler-case (si::process-lambda-list list 'function)
    (error (c) (cmperr "Illegal lambda list ~S:~%~A" list c))))

(defun c1lambda-expr (lambda-expr function-name block-name
                      &aux doc body ss is ts
                           other-decls
                           new-variables
                           (type-checks '())
                           (*permanent-data* t)
                           (old-env *cmp-env*)
                           (*cmp-env* (cmp-env-copy)))
  (declare (si::c-local))

  (cmpck (endp lambda-expr)
         "The lambda expression ~s is illegal." (cons 'LAMBDA lambda-expr))

  (multiple-value-setq (body ss ts is other-decls doc)
    (c1body (cdr lambda-expr) t))

  (when block-name (setq body (list (cons 'BLOCK (cons block-name body)))))

  (multiple-value-bind (requireds optionals rest key-flag keywords
                        allow-other-keys aux-vars)
      (cmp-process-lambda-list (car lambda-expr))

    (do ((specs (setq requireds (cdr requireds)) (cdr specs)))
        ((endp specs))
      (let* ((name (first specs))
             (var (c1make-var name ss is ts)))
        (push var type-checks)
        (setf (first specs) var)
        (push-vars var)))

    (do ((specs (setq optionals (cdr optionals)) (cdddr specs)))
        ((endp specs))
      (let* ((name (first specs))
             (var (c1make-var name ss is ts))
             (init (second specs))
             (flag (third specs)))
        (setq init (if init
                       (and-form-type (var-type var) (c1expr init) init
                                      :safe "In (LAMBDA ~a...)" function-name)
                       (default-init var)))
        (push var type-checks)
        (push-vars var)
        (when flag
          (push-vars (setq flag (c1make-var flag ss is ts))))
        (setf (first specs) var
              (second specs) init
              (third specs) flag)))

    (when rest
      (push-vars (setq rest (c1make-var rest ss is ts))))

    (do ((specs (setq keywords (cdr keywords)) (cddddr specs)))
        ((endp specs))
      (let* ((key (first specs))
             (name (second specs))
             (var (c1make-var name ss is ts))
             (init (third specs))
             (flag (fourth specs)))
        (setq init (if init
                       (and-form-type (var-type var) (c1expr init) init
                                      :safe "In (LAMBDA ~a...)" function-name)
                       (default-init var)))
        (push var type-checks)
        (push-vars var)
        (when flag
          (push-vars (setq flag (c1make-var flag ss is ts))))
        (setf (second specs) var
              (third specs) init
              (fourth specs) flag)))

    ;; Make other declarations take effect right now
    (setf *cmp-env* (reduce #'add-one-declaration other-decls
                            :initial-value *cmp-env*))

    ;; After creating all variables and processing the initalization
    ;; forms, we wil process the body. However, all free declarations,
    ;; that is declarations which do not refer to the function
    ;; arguments, have to be applied to the body. At the same time, we
    ;; replace &aux variables with a LET* form that defines them.
    (let* ((declarations other-decls)
           (type-checks (extract-lambda-type-checks
                         function-name requireds optionals
                         keywords ts other-decls))
           (type-check-forms (car type-checks))
           (let-vars (loop for spec on (nconc (cdr type-checks) aux-vars)
                           by #'cddr
                           for name = (first spec)
                           for init = (second spec)
                           collect (list name init)))
           (new-variables (cmp-env-new-variables *cmp-env* old-env))
           (already-declared-names (set-difference (mapcar #'var-name new-variables)
                                                   (mapcar #'car let-vars))))
      ;; Gather declarations for &aux variables, either special...
      (let ((specials (set-difference ss already-declared-names)))
        (when specials
          (push `(special ,@specials) declarations)))
      ;; ...ignorable...
      (let ((ignorables (loop for (var . expected-uses) in is
                              unless (member var already-declared-names)
                              collect var)))
        (when ignorables
          (push `(ignorable ,@ignorables) declarations)))
      ;; ...or type declarations
      (loop for (var . type) in ts
            unless (member var already-declared-names)
            do (push `(type ,type ,var) declarations))
      ;; ...create the enclosing LET* form for the &aux variables
      (when (or let-vars declarations)
        (setq body `((let* ,let-vars
                       (declare ,@declarations)
                       ,@body))))
      ;; ...wrap around the optional type checks
      (setq body (nconc type-check-forms body))
      ;; ...now finally compile the body with the type checks
      (let ((*cmp-env* (cmp-env-copy *cmp-env*)))
        (setf body (c1progn body)))
      ;;
      ;; ...and verify whether all variables are used.
      (dolist (var new-variables)
        (check-vref var))
      (make-c1form* 'LAMBDA
                    :local-vars new-variables
                    :args (list requireds optionals rest key-flag keywords
                                allow-other-keys)
                    doc body))))

(defun lambda-form-allowed-nargs (lambda)
  (let ((minarg 0)
        (maxarg call-arguments-limit))
    (destructuring-bind (requireds optionals rest key-flag keywords a-o-k)
        (c1form-arg 0 lambda)
      (when (and (null rest) (not key-flag) (not a-o-k))
        (setf minarg (length requireds)
              maxarg (+ minarg (/ (length optionals) 3)))))
    (values minarg maxarg)))

#| Steps:
 1. defun creates declarations for requireds + va_alist
 2. c2lambda-expr adds declarations for:
        unboxed requireds
        lexical optionals (+ supplied-p), rest, keywords (+ supplied-p)
    Lexical optionals and keywords can be unboxed if:
        a. there is more then one reference in the body
        b. they are not referenced in closures
 3. binding is performed for:
        special or unboxed requireds
        optionals, rest, keywords
 4. the function name is optionally pushed onto the IHS when
    the caller asks for it.
|#

(defun c2lambda-expr
    (lambda-list body cfun fname use-narg required-lcls closure-type
                 &aux (requireds (first lambda-list))
                 (optionals (second lambda-list))
                 (rest (third lambda-list)) rest-loc
                 (keywords (fifth lambda-list))
                 (allow-other-keys (sixth lambda-list))
                 (nreq (length requireds))
                 (nopt (/ (length optionals) 3))
                 (nkey (/ (length keywords) 4))
                 (varargs (or optionals rest keywords allow-other-keys))
                 (fname-in-ihs-p (or (policy-debug-variable-bindings)
                                     (and (policy-debug-ihs-frame)
                                          fname)))
                 simple-varargs
                 (*permanent-data* t)
                 (*unwind-exit* *unwind-exit*)
                 (*env* *env*)
                 (*inline-blocks* 0)
                 (last-arg))
  (declare (fixnum nreq nkey))

  (if (and fname ;; named function
           ;; no required appears in closure,
           (dolist (var (car lambda-list) t)
             (declare (type var var))
             (when (var-ref-ccb var) (return nil)))
           (null (second lambda-list))  ;; no optionals,
           (null (third lambda-list))   ;; no rest parameter, and
           (null (fourth lambda-list))) ;; no keywords.
    (setf *tail-recursion-info* (cons *tail-recursion-info* (car lambda-list)))
    (setf *tail-recursion-info* nil))

  ;; check arguments
  (when (policy-check-nargs)
    (if (and use-narg (not varargs))
        (wt-nl "if (ecl_unlikely(narg!=" nreq ")) FEwrong_num_arguments_anonym();")
        (when varargs
          (when requireds
            (wt-nl "if (ecl_unlikely(narg<" nreq ")) FEwrong_num_arguments_anonym();"))
          (unless (or rest keywords allow-other-keys)
            (wt-nl "if (ecl_unlikely(narg>" (+ nreq nopt) ")) FEwrong_num_arguments_anonym();"))))
    (open-inline-block))

  ;; If the number of required arguments exceeds the number of variables we
  ;; want to pass on the C stack, we pass some of the arguments to the list
  ;; of optionals, which will eventually get passed in the lisp stack.
  (when (> nreq si::c-arguments-limit)
    (setf nopt (+ nopt (- nreq si::c-arguments-limit))
          nreq si::c-arguments-limit)
    (setf optionals (nconc (loop for var in (subseq requireds si::c-arguments-limit)
                              nconc (list var *c1nil* NIL))
                           optionals)
          requireds (subseq requireds 0 si::c-arguments-limit)
          varargs t))

  ;; For each variable, set its var-loc.
  ;; For optional and keyword parameters, and lexical variables which
  ;; can be unboxed, this will be a new LCL.
  ;; The bind step later will assign to such variable.
  (labels ((wt-decl (var)
             (let ((lcl (next-lcl (var-name var))))
               (wt-nl)
               (wt (rep-type->c-name (var-rep-type var)) " " *volatile* lcl ";")
               lcl))
           (do-decl (var)
             (when (local var) ; no LCL needed for SPECIAL or LEX
               (setf (var-loc var) (wt-decl var)))))
    ;; Declare unboxed required arguments
    (loop for var in requireds
       when (unboxed var)
       do (setf (var-loc var) (wt-decl var)))
    ;; dont create rest or varargs if not used
    (when (and rest (< (var-ref rest) 1))
      (setq rest nil
            varargs (or optionals keywords allow-other-keys)))
    ;; Declare &optional variables
    (do ((opt optionals (cdddr opt)))
        ((endp opt))
      (do-decl (first opt))
      (when (third opt) (do-decl (third opt))))
    ;; Declare &rest variables
    (when rest (setq rest-loc (wt-decl rest)))
    ;; Declare &key variables
    (do ((key keywords (cddddr key)))
        ((endp key))
      (do-decl (second key))
      (when (fourth key) (do-decl (fourth key)))))

  ;; Declare and assign the variable arguments pointer
  (when varargs
    (flet ((last-variable ()
             (cond (required-lcls
                    (first (last required-lcls)))
                   ((eq closure-type 'LEXICAL)
                    (format nil "lex~D" (1- *level*)))
                   (t "narg"))))
      (if (setq simple-varargs (and (not (or rest keywords allow-other-keys))
                                    (< (+ nreq nopt) 30)))
          (wt-nl "va_list args; va_start(args,"
                 (last-variable)
                 ");")
          (wt-nl "ecl_va_list args; ecl_va_start(args,"
                 (last-variable) ",narg," nreq ");"))))

  ;; Bind required argumens. Produces C statements for unboxed variables,
  ;; which is why it is done after all declarations.
  (mapc #'bind required-lcls requireds)

  (when fname-in-ihs-p
    (open-inline-block)
    (setf *ihs-used-p* t)
    (push 'IHS *unwind-exit*)
    (when (policy-debug-variable-bindings)
      (build-debug-lexical-env (reverse requireds) t))
    (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname)
           ",_ecl_debug_env);"))

  ;; Bind optional parameters as long as there remain arguments.
  (when optionals
    ;; When binding optional values, we use two calls to BIND. This means
    ;; 'BDS-BIND is pushed twice on *unwind-exit*, which results in two calls
    ;; to bds_unwind1(), which is wrong. A simple fix is to save *unwind-exit*
    ;; which is what we do here.
    (let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)))
      ;; counter for optionals
      (wt-nl-open-brace)
      (wt-nl "int i = " nreq ";")
      (do ((opt optionals (cdddr opt)))
          ((endp opt))
        (wt-nl "if (i >= narg) {")
        (let ((*opened-c-braces* (1+ *opened-c-braces*)))
          (bind-init (second opt) (first opt))
          (when (third opt) (bind nil (third opt))))
        (wt-nl "} else {")
        (let ((*opened-c-braces* (1+ *opened-c-braces*))
              (*unwind-exit* *unwind-exit*))
          (wt-nl "i++;")
          (bind va-arg-loc (first opt))
          (when (third opt) (bind t (third opt))))
        (wt-nl "}"))
      (wt-nl-close-brace)))

  (when (or rest keywords allow-other-keys)
    (cond ((not (or keywords allow-other-keys))
           (wt-nl rest-loc " = cl_grab_rest_args(args);"))
          (t
           (cond (keywords
                  (wt-nl-open-brace) ;; Brace [1]
                  (wt-nl "cl_object keyvars[" (* 2 nkey) "];")
                  (wt-nl "cl_parse_key(args," nkey "," cfun "keys,keyvars"))
                 (t
                  (wt-nl "cl_parse_key(args,0,NULL,NULL")))
           ;; This explicit coercion is required to remove the "volatile"
           ;; declaration on some variables.
           (if rest (wt ",(cl_object*)&" rest-loc) (wt ",NULL"))
           (wt (if allow-other-keys ",TRUE);" ",FALSE);"))))
    (when rest (bind rest-loc rest)))

  (when varargs
    (wt-nl (if simple-varargs "va_end(args);" "ecl_va_end(args);")))

  ;;; Bind keywords.
  (do ((kwd keywords (cddddr kwd))
       (all-kwd nil)
       (KEYVARS[i] `(KEYVARS 0))
       (i 0 (1+ i)))
      ((endp kwd)
       (when all-kwd
         (wt-nl-h "#define " cfun "keys (&" (add-keywords (nreverse all-kwd)) ")")
         (wt-nl-close-brace))) ;; Matches [1]
    (declare (fixnum i))
    (push (first kwd) all-kwd)
    (let ((key (first kwd))
          (var (second kwd))
          (init (third kwd))
          (flag (fourth kwd)))
      (cond ((and (eq (c1form-name init) 'LOCATION)
                  (null (c1form-arg 0 init)))
             ;; no initform
             ;; ECL_NIL has been set in keyvars if keyword parameter is not supplied.
             (setf (second KEYVARS[i]) i)
             (bind KEYVARS[i] var))
            (t
             ;; with initform
             (setf (second KEYVARS[i]) (+ nkey i))
             (wt-nl "if (Null(") (wt-loc KEYVARS[i]) (wt ")) {")
             (let ((*unwind-exit* *unwind-exit*)
                   (*opened-c-braces* (1+ *opened-c-braces*)))
               (bind-init init var))
             (wt-nl "} else {")
             (let ((*opened-c-braces* (1+ *opened-c-braces*)))
               (setf (second KEYVARS[i]) i)
               (bind KEYVARS[i] var))
             (wt-nl "}")))
      (when flag
        (setf (second KEYVARS[i]) (+ nkey i))
        (bind KEYVARS[i] flag))))

  (when *tail-recursion-info*
    (push 'TAIL-RECURSION-MARK *unwind-exit*)
    (wt-nl1 "TTL:"))

  ;;; Now the parameters are ready, after all!
  (c2expr body)

  (close-inline-blocks))

(defun optimize-funcall/apply-lambda (lambda-form arguments apply-p
                                      &aux body apply-list apply-var
                                      let-vars extra-stmts all-keys)
  (multiple-value-bind (requireds optionals rest key-flag keywords
                                  allow-other-keys aux-vars)
      (cmp-process-lambda-list (car lambda-form))
    (when apply-p
      (setf apply-list (first (last arguments))
            apply-var (gensym)
            arguments (butlast arguments)))
    (setf arguments (copy-list arguments))
    (do ((scan arguments (cdr scan)))
        ((endp scan))
      (let ((form (first scan)))
        (unless (constantp form)
          (let ((aux-var (gensym)))
            (push `(,aux-var ,form) let-vars)
            (setf (car scan) aux-var)))))
    (when apply-var
      (push `(,apply-var ,apply-list) let-vars))
    (dolist (i (cdr requireds))
      (push (list i
                  (cond (arguments
                         (pop arguments))
                        (apply-p
                         `(if ,apply-var
                              (pop ,apply-var)
                              (si::dm-too-few-arguments nil)))
                        (t
                         (cmperr "Too few arguments for lambda form ~S"
                                 (cons 'LAMBDA lambda-form)))))
            let-vars))
    (do ((scan (cdr optionals) (cdddr scan)))
        ((endp scan))
      (let ((opt-var (first scan))
            (opt-flag (third scan))
            (opt-value (second scan)))
        (cond (arguments
               (setf let-vars
                     (list* `(,opt-var ,(pop arguments))
                            `(,opt-flag t)
                            let-vars)))
              (apply-p
               (setf let-vars
                     (list* `(,opt-var (if ,apply-var
                                           (pop ,apply-var)
                                           ,opt-value))
                            `(,opt-flag ,apply-var)
                            let-vars)))
              (t
               (setf let-vars
                     (list* `(,opt-var ,opt-value)
                            `(,opt-flag nil)
                            let-vars))))))
    (when (or key-flag allow-other-keys)
      (unless rest
        (setf rest (gensym))))
    (when rest
      (push `(,rest ,(if arguments
                         (if apply-p
                             `(list* ,@arguments ,apply-var)
                             `(list ,@arguments))
                         (if apply-p apply-var nil)))
            let-vars))
    (loop while aux-vars
       do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
    (do ((scan (cdr keywords) (cddddr scan)))
        ((endp scan))
      (let ((keyword (first scan))
            (key-var (second scan))
            (key-value (third scan))
            (key-flag (or (fourth scan) (gensym))))
        (push keyword all-keys)
        (setf let-vars
              (list*
               `(,key-var (if (eq ,key-flag 'si::missing-keyword) ,key-value ,key-flag))
               `(,key-flag (si::search-keyword ,rest ,keyword))
               let-vars))
        (when (fourth scan)
          (push `(setf ,key-flag (not (eq ,key-flag 'si::missing-keyword)))
                extra-stmts))))
    (when (and key-flag (not allow-other-keys))
      (push `(si::check-keyword ,rest ',all-keys) extra-stmts))
    `(let* ,(nreverse (delete-if-not #'first let-vars))
       ,@(and apply-var `((declare (ignorable ,apply-var))))
      ,@(multiple-value-bind (decl body)
           (si::find-declarations (rest lambda-form))
         (append decl extra-stmts body)))))