/[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.1 by rtoy, Sat Apr 3 17:43:06 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    ;;; hash: name -> { :GOOD | optimizer | ({modular-fun-info}*)}
1250    #+nil
1251    (eval-when (:compile-toplevel :load-toplevel :execute)
1252    (defvar *modular-funs*
1253      (make-hash-table :test 'eq))
1254    )
1255    
1256    ;;; List of increasing widths
1257    (defvar *modular-funs-widths* nil)
1258    (defstruct modular-fun-info
1259      (name (required-argument) :type symbol)
1260      (width (required-argument) :type (integer 0))
1261      (lambda-list (required-argument) :type list)
1262      (prototype (required-argument) :type symbol))
1263    
1264    (defun find-modular-version (fun-name width)
1265      (let ((infos (gethash fun-name kernel::*modular-funs*)))
1266        (if (listp infos)
1267            (find-if (lambda (item-width) (>= item-width width))
1268                     infos
1269                     :key #'modular-fun-info-width)
1270            infos)))
1271    
1272    (defun %define-modular-fun (name lambda-list prototype width)
1273      (let* ((infos (the list (gethash prototype kernel::*modular-funs*)))
1274             (info (find-if (lambda (item-width) (= item-width width))
1275                            infos
1276                            :key #'modular-fun-info-width)))
1277        (if info
1278            (unless (and (eq name (modular-fun-info-name info))
1279                         (= (length lambda-list)
1280                            (length (modular-fun-info-lambda-list info))))
1281              (setf (modular-fun-info-name info) name)
1282              (warn "Redefining modular version ~S of ~S for width ~S."
1283                    name prototype width))
1284            (setf (gethash prototype kernel::*modular-funs*)
1285                  (merge 'list
1286                         (list (make-modular-fun-info :name name
1287                                                      :width width
1288                                                      :lambda-list lambda-list
1289                                                      :prototype prototype))
1290                         infos
1291                         #'< :key #'modular-fun-info-width))))
1292      (setq *modular-funs-widths*
1293            (merge 'list (list width) *modular-funs-widths* #'<)))
1294    
1295    (defmacro define-modular-fun (name lambda-list prototype width)
1296      (check-type name symbol)
1297      (check-type prototype symbol)
1298      (check-type width unsigned-byte)
1299      (dolist (arg lambda-list)
1300        (when (member arg lambda-list-keywords)
1301          (error "Lambda list keyword ~S is not supported for ~
1302                  modular function lambda lists." arg)))
1303      `(progn
1304         (%define-modular-fun ',name ',lambda-list ',prototype ,width)
1305         (defknown ,name ,(mapcar (constantly 'integer) lambda-list)
1306           (unsigned-byte ,width)
1307           (foldable flushable movable))
1308         ;; Define the modular function just in case we need it.
1309         #+nil
1310         (defun ,name ,lambda-list
1311           (flet ((prepare-argument (arg)
1312                    (declare (integer arg))
1313                    (etypecase arg
1314                      ((unsigned-byte ,width) arg)
1315                      (fixnum (logand arg ,(1- (ash 1 width))))
1316                      (bignum (logand arg ,(1- (ash 1 width)))))))
1317             (,name ,@(loop for arg in lambda-list
1318                         collect `(prepare-argument ,arg)))))))
1319    
1320    (defun %define-good-modular-fun (name)
1321      (setf (gethash name kernel::*modular-funs*) :good)
1322      name)
1323    
1324    (defmacro define-good-modular-fun (name)
1325      (check-type name symbol)
1326      `(%define-good-modular-fun ',name))
1327    
1328    (defmacro define-modular-fun-optimizer
1329        (name ((&rest lambda-list) &key (width (gensym "WIDTH")))
1330         &body body)
1331      (check-type name symbol)
1332      (dolist (arg lambda-list)
1333        (when (member arg lambda-list-keywords)
1334          (error "Lambda list keyword ~S is not supported for ~
1335                  modular function lambda lists." arg)))
1336      (let ((call (gensym))
1337            (args (gensym)))
1338        `(setf (gethash ',name kernel::*modular-funs*)
1339               (lambda (,call ,width)
1340                 (declare (type basic-combination ,call)
1341                          (type (integer 0) width))
1342                 (let ((,args (basic-combination-args ,call)))
1343                   (when (= (length ,args) ,(length lambda-list))
1344                     (destructuring-bind ,lambda-list ,args
1345                       (declare (type continuation ,@lambda-list))
1346                       ,@body)))))))
1347    
1348    ;;; Good modular functions.  (Those that don't make the result larger.)
1349    (define-good-modular-fun logand)
1350    (define-good-modular-fun logior)
1351    

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

  ViewVC Help
Powered by ViewVC 1.1.5