(herald ofix)

;;; EMIT-COMMENT was supposed to take a format string followed by the
;;; arguments to it, but all uses of it pass a pre-formatted string as
;;; the first argument and no arguments after that.  This is not what
;;; the assembly listing generator expects, though; rather, it formats
;;; what was the first argument to EMIT-COMMENT with the rest of the
;;; arguments (always nil).  This is a problem if EMIT-COMMENT was
;;; passed a string with a tilde in it, such as when printing 'Call to
;;; unknown procedure (FORMAT T "foo ~S" ...)'.

(define (emit-comment comment)
  (set *current-comment* (list "~A" comment)))

;;; Safety

(define compiler-safety
        (make-simple-switch 'compiler-safety
                            (lambda (x)
                              (or (eq? x 'high)
                                  (eq? x 'low)))
                            'high))

(*define standard-env 'compiler-safety compiler-safety)
(*define t-implementation-env 'compiler-safety compiler-safety)

(define (finish-exps exps)
  (map! (lambda (exp)
          (set *current-module-exp* exp)
          (if (and (variable? (module-exp-def exp))
                   (let ((data
                          (definition-data
                            (variable-definition
                             (module-exp-def exp)))))
                     (xcase (compiler-safety)
                       ((high) (not (memq? 'type-unsafe data)))
                       ((low) (memq? 'type-safe-closed-form data)))))
              (make-type-safe (module-exp-node exp)))
          (fixup-node-tree (module-exp-node exp)))
        (sort-list exps (lambda (x y)
                          (fx< (module-exp-index x)
                               (module-exp-index y))))))

(set (table-entry declaration-handler-table 'type-unsafe)
     (lambda (names shape)
       (walk (lambda (name)
               (cond ((new-env-definition shape name)
                      => (lambda (def)
                           (push (definition-data def)
                                 'type-unsafe)))
                     (else
                      (missing-declaration-variable-warning
                       name 'unsafe))))
             names)))

;;; This change -- well, actually, just TYPE-SAFE-CLOSED-FORM itself --
;;; broke assignments to LSET-defined variables, because the type
;;; safetyfier would be all to happy to generate a new variable and
;;; substitute it for the first argument to *SET-VAR...but *SET-VAR is
;;; a special primop that _needs_ the global variable there.

(define (substitute-vars-in-node-tree node old-vars new-vars)
  (walk (lambda (old new)
          (if (used? old)
              (set (variable-flag old) new)))
        old-vars
        new-vars)
  (iterate tree-walk ((node node))
    (cond ((lambda-node? node)
           (walk tree-walk (call-proc+args (lambda-body node))))
          ((call-node? node)
           (walk tree-walk (call-proc+args node)))
          ((object-node? node)
           (walk tree-walk (object-operations node))
           (walk tree-walk (object-methods node))
           (tree-walk (object-proc node)))
          ((substitutable-reference-var node)
           => (lambda (new-var)
                (replace node (create-reference-node new-var))))))
  (walk (lambda (old)
          (if (used? old)
              (set (variable-flag old) nil)))
        old-vars))

(define (substitutable-reference-var node)
  (and (reference-node? node)
       (let ((var (variable-flag (reference-variable node))))
         (and var
              ;; Do not substitute if the primop uses the variable as
              ;; an lvalue.
              (not (let ((proc (call-proc (node-parent node))))
                     (and (primop-node? proc)
                          (primop.uses-L-value? (primop-value proc))
                          (eq? (node-role node)
                               (call-arg 2)))))
              var))))

;;; Collapsing cells in closures -- the definition of CELL-COLLAPSE is
;;; broken in the RISC ports of T (in that it doesn't even try to
;;; figure out whether cells can be collapsed), but I don't know why.
;;; These definitions were extracted from the m68k/VAX T ports.
                                                  
(define (cell-collapse var)
  (cond ((null? (variable-definition var))
         (set (variable-definition var) 
              (if (cell-collapsable? var) 'one 'many)))
        ((eq? (variable-definition var) 'one)
         (set (variable-definition var) 'many))))
       
(define (cell-collapsable? var)
  (every? (lambda (ref)
            (or (and (eq? (node-role ref) (call-arg 3))
                     (primop-ref? (call-proc (node-parent ref))
                                  primop/contents-location))
                (and (eq? (node-role ref) (call-arg 4))
                     (primop-ref? (call-proc (node-parent ref))
                                  primop/set-location))))
          (variable-refs var)))