Changeset 8313


Ignore:
Timestamp:
12/29/04 05:34:14 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/compile-file.lisp

    r8175 r8313  
    22;;;
    33;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id: compile-file.lisp,v 1.48 2004-11-21 05:36:31 piso Exp $
     4;;; $Id: compile-file.lisp,v 1.49 2004-12-29 05:33:56 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    9494                     (jvm::*debug* jvm::*debug*))
    9595                (jvm::process-optimization-declarations body)
    96                 (let* ((expr (list 'lambda lambda-list (list* 'block name body)) nil)
    97                        (classfile-name (next-classfile-name))
    98                        (classfile (report-error
    99                                    (jvm:compile-defun name expr nil classfile-name)))
    100                        (compiled-function (verify-load classfile)))
    101                   (cond (compiled-function
    102                          (%format t ";  ~A => ~A.cls~%" name
    103                                   (pathname-name (pathname classfile-name)))
    104                          (setf form
    105                                `(fset ',name
    106                                       (load-compiled-function ,(file-namestring classfile))
    107                                       ,*source-position*
    108                                       ',lambda-list))
    109                          (when compile-time-too
    110                            (fset name compiled-function)))
    111                         (t
    112                          (%format t ";  Unable to compile function ~A~%" name)
    113                          (let ((precompiled-function (precompile-form expr nil)))
     96                (multiple-value-bind (body decls)
     97                    (parse-body body)
     98                  (let* ((expr `(lambda ,lambda-list ,@decls (block ,name ,@body)))
     99                         (classfile-name (next-classfile-name))
     100                         (classfile (report-error
     101                                     (jvm:compile-defun name expr nil classfile-name)))
     102                         (compiled-function (verify-load classfile)))
     103                    (cond (compiled-function
     104                           (%format t ";  ~A => ~A.cls~%" name
     105                                    (pathname-name (pathname classfile-name)))
    114106                           (setf form
    115107                                 `(fset ',name
    116                                         ,precompiled-function
     108                                        (load-compiled-function ,(file-namestring classfile))
    117109                                        ,*source-position*
    118                                         ',lambda-list)))
    119                          (when compile-time-too
    120                            (eval form))))
    121                   (push name jvm::*toplevel-defuns*)
    122                   ;; If NAME is not fbound, provide a dummy definition so that
    123                   ;; getSymbolFunctionOrDie() will succeed when we try to verify that
    124                   ;; functions defined later in the same file can be loaded correctly.
    125                   (unless (fboundp name)
    126                     (setf (symbol-function name) #'dummy)
    127                     (push name *fbound-names*))))))
     110                                        ',lambda-list))
     111                           (when compile-time-too
     112                             (fset name compiled-function)))
     113                          (t
     114                           (%format t ";  Unable to compile function ~A~%" name)
     115                           (let ((precompiled-function (precompile-form expr nil)))
     116                             (setf form
     117                                   `(fset ',name
     118                                          ,precompiled-function
     119                                          ,*source-position*
     120                                          ',lambda-list)))
     121                           (when compile-time-too
     122                             (eval form))))))
     123                (push name jvm::*toplevel-defuns*)
     124                ;; If NAME is not fbound, provide a dummy definition so that
     125                ;; getSymbolFunctionOrDie() will succeed when we try to verify that
     126                ;; functions defined later in the same file can be loaded correctly.
     127                (unless (fboundp name)
     128                  (setf (symbol-function name) #'dummy)
     129                  (push name *fbound-names*)))))
    128130           (DEFMACRO
    129131            (let ((name (second form)))
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8312 r8313  
    22;;;
    33;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.327 2004-12-29 01:26:15 piso Exp $
     4;;; $Id: jvm.lisp,v 1.328 2004-12-29 05:34:14 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    39633963
    39643964(defun p2-ash (form &key (target *val*) representation)
    3965   (dformat t "p2-ash form = ~S~%" form)
     3965  (dformat t "p2-ash form = ~S representation = ~S~%" form representation)
    39663966  (require-args form 2)
    39673967  (let* ((args (cdr form))
     
    39803980     ((and var1 (fixnump arg2) (< 0 arg2 32))
    39813981      (dformat t "p2-ash case 2~%")
    3982       (emit-push-int var1)
    3983       (emit 'i2l)
    3984       (emit-push-constant-int arg2)
    3985       (emit 'lshl)
    3986       (emit-box-long)
    3987       (emit-move-from-stack target))
     3982      (case representation
     3983        (:unboxed-fixnum
     3984         (emit-push-int var1)
     3985         (emit-push-constant-int arg2)
     3986         (emit 'ishl))
     3987        (t
     3988         (emit-push-int var1)
     3989         (emit 'i2l)
     3990         (emit-push-constant-int arg2)
     3991         (emit 'lshl)
     3992         (emit-box-long)))
     3993      (emit-move-from-stack target representation))
    39883994     ((and var1 (fixnump arg2) (< -32 arg2 0))
    39893995      (dformat t "p2-ash case 3~%")
    3990       (emit 'new +lisp-fixnum-class+)
    3991       (emit 'dup)
     3996      (unless (eq representation :unboxed-fixnum)
     3997        (emit 'new +lisp-fixnum-class+)
     3998        (emit 'dup))
    39923999      (emit-push-int var1)
    39934000      (emit-push-constant-int (- arg2))
    39944001      (emit 'ishr)
    3995       (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
    3996       (emit-move-from-stack target))
     4002      (unless (eq representation :unboxed-fixnum)
     4003        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
     4004      (emit-move-from-stack target representation))
    39974005     (var2
    39984006      (dformat t "p2-ash case 4~%")
     
    40044012                          "(I)Lorg/armedbear/lisp/LispObject;"
    40054013                          -1)
    4006       (emit-move-from-stack target))
     4014      (when (eq representation :unboxed-fixnum)
     4015        (emit-unbox-fixnum))
     4016      (emit-move-from-stack target representation))
    40074017     ((fixnump arg2)
    40084018      (dformat t "p2-ash case 5~%")
     
    40144024                          "(I)Lorg/armedbear/lisp/LispObject;"
    40154025                          -1)
    4016       (emit-move-from-stack target))
     4026      (when (eq representation :unboxed-fixnum)
     4027        (emit-unbox-fixnum))
     4028      (emit-move-from-stack target representation))
    40174029     (t
    40184030      (dformat t "p2-ash case 6~%")
     
    40264038             (arg2 (second args))
    40274039             (var1 (unboxed-fixnum-variable arg1)))
     4040        (dformat t "p2-logand var1 = ~S~%" var1)
     4041        (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2))
    40284042        (cond
     4043         ((and (integerp arg1) (integerp arg2))
     4044          (dformat t "p2-logand case 1~%")
     4045          (compile-constant (logand arg1 arg2) :target target :representation representation)
     4046          (return-from p2-logand t))
     4047         ((and (fixnump arg2) (zerop arg2))
     4048          (dformat t "p2-logand case 2~%")
     4049          (compile-constant 0 :target target :representation representation)
     4050          (return-from p2-logand t))
    40294051         ((and var1 (fixnump arg2))
     4052          (dformat t "p2-logand case 3~%")
    40304053          (unless (eq representation :unboxed-fixnum)
    40314054            (emit 'new +lisp-fixnum-class+)
     
    40394062          (return-from p2-logand t))
    40404063         ((fixnump arg2)
    4041           (compile-form arg1 :target :stack)
    4042           (maybe-emit-clear-values arg1)
    4043           (emit-push-constant-int arg2)
    4044           (emit-invokevirtual +lisp-object-class+
    4045                               "logand"
    4046                               "(I)Lorg/armedbear/lisp/LispObject;"
    4047                               -1)
    4048           (emit-move-from-stack target)
     4064          (dformat t "p2-logand case 4~%")
     4065          (let ((type (derive-type arg1)))
     4066            (dformat t "p2-logand arg1 derived type = ~S~%" type)
     4067            (cond
     4068             ((subtypep type 'fixnum)
     4069              (dformat t "p2-logand case 4a~%")
     4070              (unless (eq representation :unboxed-fixnum)
     4071                (emit 'new +lisp-fixnum-class+)
     4072                (emit 'dup))
     4073              (compile-form arg1 :target :stack :representation :unboxed-fixnum)
     4074              (maybe-emit-clear-values arg1)
     4075              (emit-push-constant-int arg2)
     4076              (emit 'iand)
     4077              (unless (eq representation :unboxed-fixnum)
     4078                (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
     4079              (emit-move-from-stack target representation))
     4080             (t
     4081              (dformat t "p2-logand case 4b~%")
     4082              (compile-form arg1 :target :stack)
     4083              (maybe-emit-clear-values arg1)
     4084              (emit-push-constant-int arg2)
     4085              (emit-invokevirtual +lisp-object-class+
     4086                                  "logand"
     4087                                  "(I)Lorg/armedbear/lisp/LispObject;"
     4088                                  -1)
     4089              (when (eq representation :unboxed-fixnum)
     4090                (emit-unbox-fixnum))
     4091              (emit-move-from-stack target representation))))
    40494092          (return-from p2-logand t))))))
     4093  (dformat t "p2-logand default case~%")
    40504094  (compile-function-call form target representation))
     4095
     4096(defun derive-type (form)
     4097  (when (consp form)
     4098    (let ((op (car form)))
     4099      (case op
     4100        (ASH
     4101         (dformat t "derive-type ASH case form = ~S~%" form)
     4102         (let* ((arg1 (second form))
     4103                (var1 (unboxed-fixnum-variable arg1))
     4104                (arg2 (third form)))
     4105           (dformat t "derive-type ASH case var1 = ~S~%" var1)
     4106           (when (and var1 (fixnump arg2) (minusp arg2))
     4107             (return-from derive-type 'fixnum)))))))
     4108  t)
    40514109
    40524110(defun compile-length (form &key (target *val*) representation)
     
    51005158(defun compile-defun (name form environment &optional (classfile "out.class"))
    51015159  ;;   (dformat t "COMPILE-DEFUN ~S ~S~%" name classfile)
     5160  ;;   (dformat t "compile-defun form = ~S~%" form)
    51025161  (unless (eq (car form) 'LAMBDA)
    51035162    (return-from compile-defun nil))
Note: See TracChangeset for help on using the changeset viewer.