Changeset 11607
 Timestamp:
 01/31/09 08:38:52 (13 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/compilerpass2.lisp
r11604 r11607 513 513 (defun typerepresentation (thetype) 514 514 "Converts a type specification or compiler type into a representation." 515 (when (null thetype) 516 (returnfrom typerepresentation)) 515 517 (do* ((types typerepresentations (cdr types))) 516 518 ((endp types) nil) … … 1072 1074 104 ; imul 1073 1075 105 ; lmul 1076 106 ; fmul 1077 107 ; dmul 1074 1078 116 ; ineg 1075 1079 117 ; lneg … … 1088 1092 133 ; i2l 1089 1093 134 ; i2f 1094 135 ; i2d 1090 1095 136 ; l2i 1091 1096 148 ; lcmp … … 6290 6295 6291 6296 (defvar numericoptypederivation 6292 `(((+  * /)6297 `(((+  *) 6293 6298 (integer integer ,#'deriveintegertype) 6299 (integer singlefloat singlefloat) 6300 (integer doublefloat doublefloat) 6301 (singlefloat integer singlefloat) 6302 (singlefloat doublefloat doublefloat) 6303 (doublefloat integer doublefloat) 6304 (doublefloat singlefloat doublefloat)) 6305 ((/) 6294 6306 (integer singlefloat singlefloat) 6295 6307 (integer doublefloat doublefloat) … … 6377 6389 resulttype)) 6378 6390 6391 (defineintboundsderivation * (low1 high1 low2 high2) 6392 (cond ((or (null low1) (null low2)) 6393 (values nil nil)) 6394 ((or (null high1) (null high2)) 6395 (values (if (or (minusp low1) (minusp low2)) 6396 ( (* (abs low1) (abs low2))) 6397 (* low1 low2)) 6398 nil)) 6399 ((or (minusp low1) (minusp low2)) 6400 (let ((max (* (max (abs low1) (abs high1)) 6401 (max (abs low2) (abs high2))))) 6402 (values ( max) max))) 6403 (t 6404 (values (* low1 low2) (* high1 high2))))) 6405 6379 6406 (defun derivetypetimes (form) 6380 6407 (let ((args (cdr form)) 6381 6408 (resulttype t)) 6382 6409 (when (= (length args) 2) 6383 (let ((arg1 (%car args)) 6384 (arg2 (%cadr args))) 6385 (when (and (integerp arg1) (integerp arg2)) 6386 (let ((n (* arg1 arg2))) 6387 (returnfrom derivetypetimes (%makeintegertype n n)))) 6388 (whenargsinteger 6389 (arg1 arg2) 6390 (type1 low1 high1 type2 low2 high2) 6391 ((low nil) 6392 (high nil)) 6393 (cond ((not (and low1 low2)) 6394 ;; Nothing to do. 6395 ) 6396 ((or (minusp low1) (minusp low2)) 6397 (when (and high1 high2) 6398 (let ((max (* (max (abs low1) (abs high1)) 6399 (max (abs low2) (abs high2))))) 6400 (setf low ( max) 6401 high max)))) 6402 (t 6403 (setf low (* low1 low2)) 6404 (when (and high1 high2) 6405 (setf high (* high1 high2))))) 6406 (setf resulttype (%makeintegertype low high))))) 6410 (setf resulttype 6411 (derivetypenumericop (car form) 6412 (derivecompilertype (car args)) 6413 (derivecompilertype (cadr args))))) 6407 6414 resulttype)) 6408 6415 … … 6765 6772 (emitmovefromstack target representation))) 6766 6773 6767 (defun twolongintstimes/plus/minus (arg1 arg2 instruction representation)6768 (compileform arg1 'stack :int)6769 (emit 'i2l)6770 (compileform arg2 'stack :int)6771 (emit 'i2l)6772 (maybeemitclearvalues arg1 arg2)6773 (emit instruction)6774 (convertrepresentation :long representation))6775 6776 6774 (defun p2times (form target representation) 6777 6775 (case (length form) … … 6780 6778 (arg1 (%car args)) 6781 6779 (arg2 (%cadr args)) 6782 type1 type2 resulttypevalue)6780 resulttype resultrep value) 6783 6781 (when (fixnump arg1) 6784 6782 (rotatef arg1 arg2)) 6785 (setf type1 (makeintegertype (derivetype arg1)) 6786 type2 (makeintegertype (derivetype arg2)) 6787 resulttype (makeintegertype (derivetype form))) 6783 (setf resulttype (derivecompilertype form) 6784 resultrep (typerepresentation resulttype)) 6788 6785 (cond ((and (numberp arg1) (numberp arg2)) 6789 6786 (dformat t "p2times case 1~%") … … 6792 6789 (dformat t "p2times case 1a~%") 6793 6790 (compileconstant value target representation)) 6794 ((and (fixnumtypep type1) 6795 (fixnumtypep type2)) 6796 (cond ((fixnumtypep resulttype) 6797 (unless (eq representation :int) 6798 (newfixnum)) 6799 (compileformsandmaybeemitclearvalues arg1 'stack :int 6800 arg2 'stack :int) 6801 (emit 'imul) 6802 (unless (eq representation :int) 6803 (emitinvokespecialinit +lispfixnumclass+ '("I")) 6804 (fixboxing representation 'fixnum))) 6791 (resultrep 6792 (compileformsandmaybeemitclearvalues 6793 arg1 'stack resultrep 6794 arg2 'stack resultrep) 6795 (emit (case resultrep 6796 (:int 'imul) 6797 (:long 'lmul) 6798 (:float 'fmul) 6799 (:double 'dmul) 6805 6800 (t 6806 (twolongintstimes/plus/minus 6807 arg1 arg2 'lmul representation)))6801 (sys::format t "p2times: unsupported rep case")))) 6802 (convertrepresentation resultrep representation) 6808 6803 (emitmovefromstack target representation)) 6809 ((and (javalongtypep type1)6810 (javalongtypep type2)6811 (javalongtypep resulttype))6812 (compileformsandmaybeemitclearvalues arg1 'stack :long6813 arg2 'stack :long)6814 (emit 'lmul)6815 (convertrepresentation :long representation)6816 (emitmovefromstack target representation))6817 6804 ((fixnump arg2) 6818 6805 ;; (format t "p2times case 3~%") … … 6893 6880 (t 6894 6881 (compilefunctioncall form target representation)))) 6895 6896 (defun fixnumresultplus/minus (target representation resulttype arg1 arg26897 intop longop)6898 (cond ((or (eq representation :int)6899 (fixnumtypep resulttype))6900 (newfixnum (null representation))6901 (compileformsandmaybeemitclearvalues arg1 'stack :int6902 arg2 'stack :int)6903 (emit intop)6904 (emitfixnuminit representation))6905 (t6906 (twolongintstimes/plus/minus6907 arg1 arg2 longop representation)))6908 (emitmovefromstack target representation))6909 6882 6910 6883 (defun p2plus (form target representation)
Note: See TracChangeset
for help on using the changeset viewer.