/[cmucl]/src/compiler/macros.lisp
ViewVC logotype

Diff of /src/compiler/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.52 by gerd, Wed Sep 24 09:48:18 2003 UTC revision 1.52.2.2 by rtoy, Sun Apr 4 14:39:13 2004 UTC
# Line 1237  Line 1237 
1237  (defmacro eposition (&rest args)  (defmacro eposition (&rest args)
1238    `(or (position ,@args)    `(or (position ,@args)
1239         (error "Shouldn't happen?")))         (error "Shouldn't happen?")))
1240    
1241    
1242    ;;; Modular functions
1243    
1244    ;;; For a documentation, see CUT-TO-WIDTH.
1245    
1246    #+modular-arith
1247    (sys:register-lisp-feature :modular-arith)
1248    
1249    #+modular-arith
1250    (progn
1251    ;;; List of increasing widths
1252    (defvar *modular-funs-widths* nil)
1253    (defstruct modular-fun-info
1254      (name (required-argument) :type symbol)
1255      (width (required-argument) :type (integer 0))
1256      (lambda-list (required-argument) :type list)
1257      (prototype (required-argument) :type symbol))
1258    
1259    (defun find-modular-version (fun-name width)
1260      (let ((infos (gethash fun-name kernel::*modular-funs*)))
1261        (if (listp infos)
1262            (find-if (lambda (item-width) (>= item-width width))
1263                     infos
1264                     :key #'modular-fun-info-width)
1265            infos)))
1266    
1267    (defun %define-modular-fun (name lambda-list prototype width)
1268      (let* ((infos (the list (gethash prototype kernel::*modular-funs*)))
1269             (info (find-if (lambda (item-width) (= item-width width))
1270                            infos
1271                            :key #'modular-fun-info-width)))
1272        (if info
1273            (unless (and (eq name (modular-fun-info-name info))
1274                         (= (length lambda-list)
1275                            (length (modular-fun-info-lambda-list info))))
1276              (setf (modular-fun-info-name info) name)
1277              (warn "Redefining modular version ~S of ~S for width ~S."
1278                    name prototype width))
1279            (setf (gethash prototype kernel::*modular-funs*)
1280                  (merge 'list
1281                         (list (make-modular-fun-info :name name
1282                                                      :width width
1283                                                      :lambda-list lambda-list
1284                                                      :prototype prototype))
1285                         infos
1286                         #'< :key #'modular-fun-info-width))))
1287      (setq *modular-funs-widths*
1288            (merge 'list (list width) *modular-funs-widths* #'<)))
1289    
1290    (defmacro define-modular-fun (name lambda-list prototype width)
1291      (check-type name symbol)
1292      (check-type prototype symbol)
1293      (check-type width unsigned-byte)
1294      (dolist (arg lambda-list)
1295        (when (member arg lambda-list-keywords)
1296          (error "Lambda list keyword ~S is not supported for ~
1297                  modular function lambda lists." arg)))
1298      `(progn
1299         (%define-modular-fun ',name ',lambda-list ',prototype ,width)
1300         (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
1301           (unsigned-byte ,width)
1302           (foldable flushable movable))
1303         ;; Define the modular function just in case we need it.
1304         #+nil
1305         (defun ,name ,lambda-list
1306           (flet ((prepare-argument (arg)
1307                    (declare (integer arg))
1308                    (etypecase arg
1309                      ((unsigned-byte ,width) arg)
1310                      (fixnum (logand arg ,(1- (ash 1 width))))
1311                      (bignum (logand arg ,(1- (ash 1 width)))))))
1312             (,name ,@(loop for arg in lambda-list
1313                         collect `(prepare-argument ,arg)))))))
1314    
1315    (defun %define-good-modular-fun (name)
1316      (setf (gethash name kernel::*modular-funs*) :good)
1317      name)
1318    
1319    (defmacro define-good-modular-fun (name)
1320      (check-type name symbol)
1321      `(%define-good-modular-fun ',name))
1322    
1323    (defmacro define-modular-fun-optimizer
1324        (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
1325         &body body)
1326      (check-type name symbol)
1327      (dolist (arg lambda-list)
1328        (when (member arg lambda-list-keywords)
1329          (error "Lambda list keyword ~S is not supported for ~
1330                  modular function lambda lists." arg)))
1331      (let ((call (gensym))
1332            (args (gensym)))
1333        `(setf (gethash ',name kernel::*modular-funs*)
1334               (lambda (,call ,width)
1335                 (declare (type basic-combination ,call)
1336                          (type (integer 0) width))
1337                 (let ((,args (basic-combination-args ,call)))
1338                   (when (= (length ,args) ,(length lambda-list))
1339                     (destructuring-bind ,lambda-list ,args
1340                       (declare (type continuation ,@lambda-list))
1341                       ,@body)))))))
1342    
1343    ;;; Good modular functions.  (Those that don't make the result larger.)
1344    (define-good-modular-fun logand)
1345    (define-good-modular-fun logior)
1346    )                                       ; modular-arith

Legend:
Removed from v.1.52  
changed lines
  Added in v.1.52.2.2

  ViewVC Help
Powered by ViewVC 1.1.5