├── demo.lisp ├── effective-method.lisp ├── generic-functions.lisp ├── julia-function.lisp ├── julia-functions.asd ├── julia-method.lisp ├── lambda-lists.lisp ├── optimization.lisp ├── packages.lisp └── utilities.lisp /demo.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defgeneric lisp-sum (vector scalar)) 4 | 5 | (defgeneric julia-sum (vector scalar) 6 | (:generic-function-class julia-function)) 7 | 8 | (progn 9 | (defmethod lisp-sum ((vector vector) (real real)) 10 | #1= 11 | (let ((sum real)) 12 | (declare (real sum)) 13 | (loop for index below (length vector) do 14 | (incf sum (elt vector index))) 15 | sum)) 16 | 17 | (defmethod julia-sum ((vector vector) (real real)) 18 | #1#)) 19 | 20 | (defmethod lisp-sum :before ((vector vector) (real real)) 21 | (print "Calling LISP-SUM.")) 22 | 23 | (defmethod julia-sum :before ((vector vector) (real real)) 24 | (print "Calling JULIA-SUM.")) 25 | 26 | (defun benchmark (fn) 27 | (let* ((n (expt 10 7)) 28 | (vector (make-array n :element-type 'double-float 29 | :initial-element 1d0))) 30 | (time 31 | (loop repeat 10 do 32 | (assert (= (* 1d0 n) (funcall fn vector 0d0))))))) 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | ;;; Wait, it gets better.... :) 41 | 42 | (defun lisp-benchmark () 43 | (let* ((n (expt 10 7)) 44 | (vector (make-array n :element-type 'double-float 45 | :initial-element 1d0))) 46 | (time 47 | (loop repeat 10 do 48 | (assert (= (* 1d0 n) (lisp-sum vector 0d0))))))) 49 | 50 | (defun julia-benchmark () 51 | (let* ((n (expt 10 7)) 52 | (vector (make-array n :element-type 'double-float 53 | :initial-element 1d0))) 54 | (time 55 | (loop repeat 10 do 56 | (assert (= (* 1d0 n) (julia-sum vector 0d0))))))) 57 | -------------------------------------------------------------------------------- /effective-method.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defun expand-effective-method-body 4 | (effective-method generic-function lambda-list) 5 | (trivial-macroexpand-all:macroexpand-all 6 | `(let ((.gf. #',(generic-function-name generic-function))) 7 | (declare (ignorable .gf.)) 8 | #+sbcl(declare (sb-ext:disable-package-locks common-lisp:call-method)) 9 | #+sbcl(declare (sb-ext:disable-package-locks common-lisp:make-method)) 10 | #+sbcl(declare (sb-ext:disable-package-locks sb-pcl::check-applicable-keywords)) 11 | #+sbcl(declare (sb-ext:disable-package-locks sb-pcl::%no-primary-method)) 12 | (macrolet 13 | (;; SBCL introduces explicit keyword argument checking into 14 | ;; the effective method. Since we do our own checking, we 15 | ;; can safely disable it. However, we touch the relevant 16 | ;; variables to prevent unused variable warnings. 17 | #+sbcl 18 | (sb-pcl::check-applicable-keywords (&rest args) 19 | (declare (ignore args)) 20 | `(progn sb-pcl::.valid-keys. sb-pcl::.keyargs-start. (values))) 21 | ;; SBCL introduces a magic form to report when there are no 22 | ;; primary methods. The problem is that this form contains a 23 | ;; reference to the literal generic function, which is not an 24 | ;; externalizable object. Our solution is to replace it with 25 | ;; something portable. 26 | #+sbcl 27 | (sb-pcl::%no-primary-method (&rest args) 28 | (declare (ignore args)) 29 | `(apply #'no-primary-method .gf. ,@',(lambda-list-apply-arguments lambda-list)))) 30 | ,(wrap-in-call-method-macrolet 31 | effective-method 32 | generic-function 33 | lambda-list))))) 34 | 35 | (defun wrap-in-call-method-macrolet (form generic-function lambda-list) 36 | `(macrolet ((call-method (method &optional next-methods) 37 | (expand-call-method 38 | method 39 | next-methods 40 | ',lambda-list 41 | ',(class-name 42 | (generic-function-method-class generic-function))))) 43 | ,(wrap-in-reinitialize-arguments form lambda-list))) 44 | 45 | (defun wrap-in-reinitialize-arguments (form lambda-list) 46 | (let ((anonymized-lambda-list 47 | (anonymize-ordinary-lambda-list lambda-list))) 48 | `(flet ((reinitialize-arguments ,anonymized-lambda-list 49 | ,@(mapcar 50 | (lambda (place value) 51 | `(setf ,place ,value)) 52 | (lambda-list-variables lambda-list) 53 | (lambda-list-variables anonymized-lambda-list)))) 54 | (declare (ignorable #'reinitialize-arguments)) 55 | (declare (inline reinitialize-arguments)) 56 | ,form))) 57 | 58 | (defun expand-call-method (method next-methods lambda-list method-class) 59 | (wrap-in-next-methods 60 | (call-julia-method-lambda 61 | (coerce-to-julia-method method lambda-list method-class) 62 | lambda-list) 63 | next-methods 64 | lambda-list 65 | method-class)) 66 | 67 | (defun coerce-to-julia-method (method lambda-list method-class) 68 | (cond ((typep method 'julia-method) 69 | method) 70 | ((and (consp method) 71 | (eql (car method) 'make-method) 72 | (null (cddr method))) 73 | (make-instance method-class 74 | :lambda-list lambda-list 75 | :specializers (make-list (length (parse-ordinary-lambda-list lambda-list)) 76 | :initial-element (find-class 't)) 77 | :qualifiers '() 78 | :function #'values 79 | '.lambda. 80 | `(lambda ,lambda-list 81 | (declare (ignorable ,@(lambda-list-variables lambda-list))) 82 | ,(second method)))) 83 | (t 84 | (error "Cannot turn ~S into an inlineable method." 85 | method)))) 86 | 87 | (defun wrap-in-next-methods (form next-methods lambda-list method-class) 88 | (if (null next-methods) 89 | `(flet ((next-method-p () nil) 90 | (call-next-method () 91 | (apply 92 | #'no-next-method 93 | .gf. 94 | (class-prototype (find-class ',method-class)) 95 | ,@(lambda-list-apply-arguments lambda-list)))) 96 | (declare (ignorable #'next-method-p #'call-next-method)) 97 | ,form) 98 | (wrap-in-next-methods 99 | `(flet ((next-method-p () t) 100 | (call-next-method (&rest args) 101 | (unless (null args) 102 | (apply #'reinitialize-arguments args)) 103 | (call-method ,(first next-methods) ,(rest next-methods)))) 104 | (declare (ignorable #'next-method-p #'call-next-method)) 105 | ,form) 106 | (rest next-methods) 107 | lambda-list 108 | method-class))) 109 | 110 | (defun call-julia-method-lambda (method lambda-list) 111 | (multiple-value-bind (g-required g-optional g-rest-var g-keyword) 112 | (parse-ordinary-lambda-list lambda-list) 113 | (multiple-value-bind (m-required m-optional m-rest-var m-keyword) 114 | (parse-ordinary-lambda-list (method-lambda-list method)) 115 | ;; Assert that the method has arguments that are congruent to those 116 | ;; of the corresponding generic function. 117 | (assert (or (= (length g-required) 118 | (length m-required)))) 119 | (assert (= (length g-optional) 120 | (length m-optional))) 121 | (when (null g-rest-var) 122 | (assert (null m-rest-var))) 123 | `(funcall 124 | ,(julia-method-lambda method) 125 | ;; Required arguments. 126 | ,@(mapcar #'required-info-variable g-required) 127 | ;; Optional arguments. 128 | ,@(loop for g-info in g-optional 129 | for m-info in m-optional 130 | append 131 | (if (null (optional-info-suppliedp g-info)) 132 | `(,(optional-info-variable g-info)) 133 | (let ((value 134 | `(if ,(optional-info-suppliedp g-info) 135 | ,(optional-info-variable g-info) 136 | ,(optional-info-initform m-info)))) 137 | (if (null (optional-info-suppliedp m-info)) 138 | `(,value) 139 | `(,value ,(optional-info-suppliedp g-info)))))) 140 | ;; The rest argument. 141 | ,@(if (null m-rest-var) 142 | `() 143 | `(,g-rest-var)) 144 | ;; Keyword arguments. 145 | ,@(loop for m-info in m-keyword 146 | for g-info = (find (keyword-info-keyword m-info) g-keyword 147 | :key #'keyword-info-keyword) 148 | append 149 | (if (null (keyword-info-suppliedp g-info)) 150 | `(,(keyword-info-variable g-info)) 151 | (let ((value 152 | `(if ,(keyword-info-suppliedp g-info) 153 | ,(keyword-info-variable g-info) 154 | ,(keyword-info-initform m-info)))) 155 | (if (null (keyword-info-suppliedp m-info)) 156 | `(,value) 157 | `(,value ,(keyword-info-suppliedp g-info)))))))))) 158 | -------------------------------------------------------------------------------- /generic-functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defgeneric optimize-function-call (generic-function specializers) 4 | 5 | (defgeneric no-primary-method (generic-function &rest arguments) 6 | (:method ((generic-function generic-function) &rest arguments) 7 | (error "~@" 9 | generic-function arguments))) 10 | 11 | -------------------------------------------------------------------------------- /julia-function.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defclass julia-function (standard-generic-function) 4 | ((%emf-defuns 5 | :initform (make-hash-table :test #'equal) 6 | :accessor julia-function-emf-defuns)) 7 | (:default-initargs :method-class (find-class 'julia-method)) 8 | (:metaclass funcallable-standard-class)) 9 | -------------------------------------------------------------------------------- /julia-functions.asd: -------------------------------------------------------------------------------- 1 | (defsystem "julia-functions" 2 | :author "Marco Heisig " 3 | :description "A quick hack to get the Julia compilation mode into CLOS." 4 | :license "MIT" 5 | :depends-on 6 | ("alexandria" 7 | "closer-mop" 8 | "trivial-macroexpand-all") 9 | 10 | :serial t 11 | :components 12 | ((:file "packages") 13 | (:file "utilities") 14 | (:file "lambda-lists") 15 | (:file "effective-method") 16 | (:file "julia-method") 17 | (:file "julia-function") 18 | (:file "optimization"))) 19 | -------------------------------------------------------------------------------- /julia-method.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defclass julia-method (standard-method) 4 | ((%lambda 5 | :initarg .lambda. 6 | :reader julia-method-lambda 7 | :initform (alexandria:required-argument '.lambda.)))) 8 | -------------------------------------------------------------------------------- /lambda-lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;; 5 | ;;; Lambda List Parsing 6 | 7 | (deftype local-variable () 8 | '(and symbol (not (satisfies constantp)))) 9 | 10 | (defclass required-info () 11 | ((%variable 12 | :initarg :variable 13 | :reader required-info-variable 14 | :type local-variable 15 | :initform (alexandria:required-argument :variable)))) 16 | 17 | (defclass optional-info () 18 | ((%variable 19 | :initarg :variable 20 | :reader optional-info-variable 21 | :type local-variable 22 | :initform (alexandria:required-argument :variable)) 23 | (%initform 24 | :initarg :initform 25 | :reader optional-info-initform 26 | :initform nil) 27 | (%suppliedp 28 | :initarg :suppliedp 29 | :reader optional-info-suppliedp 30 | :type (or null local-variable) 31 | :initform nil))) 32 | 33 | (defclass keyword-info () 34 | ((%keyword 35 | :initarg :keyword 36 | :reader keyword-info-keyword 37 | :type keyword 38 | :initform (alexandria:required-argument :keyword)) 39 | (%variable 40 | :initarg :variable 41 | :reader keyword-info-variable 42 | :type local-variable 43 | :initform (alexandria:required-argument :variable)) 44 | (%initform 45 | :initarg :initform 46 | :reader keyword-info-initform 47 | :initform nil) 48 | (%suppliedp 49 | :initarg :suppliedp 50 | :reader keyword-info-suppliedp 51 | :type (or null local-variable) 52 | :initform nil))) 53 | 54 | (defclass auxiliary-info () 55 | ((%variable 56 | :initarg :variable 57 | :reader auxiliary-info-variable 58 | :type local-variable 59 | :initform (alexandria:required-argument :variable)) 60 | (%initform 61 | :initarg :initform 62 | :reader auxiliary-info-initform 63 | :initform nil))) 64 | 65 | (defun parse-ordinary-lambda-list (lambda-list) 66 | "Returns six values: 67 | 68 | 1. A list of REQUIRED-INFO instances, one for each required argument. 69 | 70 | 2. A list of OPTIONAL-INFO instances, one for each optional argument. 71 | 72 | 3. The name of the rest variable, or NIL, if there is none. 73 | 74 | 4. A list of KEYWORD-INFO instances, one for each keyword argument. 75 | 76 | 5. A boolean, indicating whether &allow-other-keys is present. 77 | 78 | 6. A list of AUXILIARY-INFO instances, one for each auxiliary argument. 79 | 80 | Can parse all but specialized lambda lists. 81 | " 82 | (let ((required '()) 83 | (optional '()) 84 | (keyword '()) 85 | (auxiliary '()) 86 | (rest-var nil) 87 | (allow-other-keys-p nil)) 88 | (labels ((fail () 89 | (error "Malformed lambda list: ~S" lambda-list)) 90 | (parse-required (lambda-list) 91 | (unless (endp lambda-list) 92 | (let ((item (first lambda-list))) 93 | (case item 94 | (&optional (parse-&optional (rest lambda-list))) 95 | (&rest (parse-&rest (rest lambda-list))) 96 | (&key (parse-&key (rest lambda-list))) 97 | (&aux (parse-&aux (rest lambda-list))) 98 | (#.(set-difference lambda-list-keywords '(&optional &rest &key &aux)) 99 | (fail)) 100 | (otherwise 101 | (push (parse-reqired-item item) required) 102 | (parse-required (rest lambda-list))))))) 103 | (parse-&optional (lambda-list) 104 | (unless (endp lambda-list) 105 | (let ((item (first lambda-list))) 106 | (case item 107 | (&rest (parse-&rest (rest lambda-list))) 108 | (&key (parse-&key (rest lambda-list))) 109 | (&aux (parse-&aux (rest lambda-list))) 110 | (#.(set-difference lambda-list-keywords '(&rest &key &aux)) 111 | (fail)) 112 | (otherwise 113 | (push (parse-optional-item item) optional) 114 | (parse-&optional (rest lambda-list))))))) 115 | (parse-&rest (lambda-list) 116 | (unless (consp lambda-list) 117 | (fail)) 118 | (let ((item (first lambda-list))) 119 | (unless (symbolp item) 120 | (fail)) 121 | (unless (null rest-var) 122 | (fail)) 123 | (setf rest-var item) 124 | (unless (endp (rest lambda-list)) 125 | (case (first (rest lambda-list)) 126 | (&key (parse-&key (rest (rest lambda-list)))) 127 | (&aux (parse-&aux (rest (rest lambda-list)))) 128 | (otherwise (fail)))))) 129 | (parse-&key (lambda-list) 130 | (unless (endp lambda-list) 131 | (let ((item (first lambda-list))) 132 | (case item 133 | (&allow-other-keys (parse-&allow-other-keys (rest lambda-list))) 134 | (&aux (parse-&aux (rest lambda-list))) 135 | (#.(set-difference lambda-list-keywords '(&allow-other-keys &aux)) 136 | (fail)) 137 | (otherwise 138 | (push (parse-keyword-item item) keyword) 139 | (parse-&key (rest lambda-list))))))) 140 | (parse-&allow-other-keys (lambda-list) 141 | (setf allow-other-keys-p t) 142 | (unless (endp lambda-list) 143 | (case (first lambda-list) 144 | (&aux (parse-&aux (rest lambda-list))) 145 | (otherwise 146 | (fail))))) 147 | (parse-&aux (lambda-list) 148 | (unless (endp lambda-list) 149 | (let ((item (first lambda-list))) 150 | (case item 151 | (#.lambda-list-keywords (fail)) 152 | (otherwise 153 | (push (parse-auxiliary-item item) auxiliary) 154 | (parse-&aux (rest lambda-list)))))))) 155 | (parse-required lambda-list)) 156 | (values 157 | (nreverse required) 158 | (nreverse optional) 159 | rest-var 160 | (nreverse keyword) 161 | allow-other-keys-p 162 | (nreverse auxiliary)))) 163 | 164 | (defun parse-reqired-item (item) 165 | (unless (typep item 'local-variable) 166 | (error "Not a valid lambda list variable: ~S" 167 | item)) 168 | (make-instance 'required-info 169 | :variable item)) 170 | 171 | (defun parse-optional-item (item) 172 | (typecase item 173 | (local-variable 174 | (make-instance 'optional-info 175 | :variable item)) 176 | ((cons local-variable null) 177 | (make-instance 'optional-info 178 | :variable (first item))) 179 | ((cons local-variable (cons t null)) 180 | (make-instance 'optional-info 181 | :variable (first item) 182 | :initform (second item))) 183 | ((cons local-variable (cons t (cons local-variable null))) 184 | (make-instance 'optional-info 185 | :variable (first item) 186 | :initform (second item) 187 | :suppliedp (third item))) 188 | (t (error "Invalid &optional lambda list item: ~S" 189 | item)))) 190 | 191 | (defun parse-keyword-item (item) 192 | (labels ((fail () 193 | (error "Invalid &key lambda list item: ~S" 194 | item)) 195 | (parse-keyword-var (item) 196 | (etypecase item 197 | (symbol 198 | (values (intern (symbol-name item) :keyword) 199 | item)) 200 | ((cons symbol null) 201 | (values (intern (symbol-name (first item)) :keyword) 202 | (first item))) 203 | ((cons keyword (cons symbol null)) 204 | (values (first item) 205 | (second item))) 206 | (t (fail))))) 207 | (typecase item 208 | (local-variable 209 | (make-instance 'keyword-info 210 | :variable item 211 | :keyword (intern (symbol-name item) :keyword))) 212 | ((cons t null) 213 | (multiple-value-bind (keyword variable) 214 | (parse-keyword-var (first item)) 215 | (make-instance 'keyword-info 216 | :variable variable 217 | :keyword keyword))) 218 | ((cons t (cons t null)) 219 | (multiple-value-bind (keyword variable) 220 | (parse-keyword-var (first item)) 221 | (make-instance 'keyword-info 222 | :variable variable 223 | :keyword keyword 224 | :initform (second item)))) 225 | ((cons t (cons t (cons local-variable null))) 226 | (multiple-value-bind (keyword variable) 227 | (parse-keyword-var (first item)) 228 | (make-instance 'keyword-info 229 | :variable variable 230 | :keyword keyword 231 | :initform (second item) 232 | :suppliedp (third item)))) 233 | (t (fail))))) 234 | 235 | (defun parse-auxiliary-item (item) 236 | (typecase item 237 | (local-variable 238 | (make-instance 'auxiliary-info 239 | :variable item)) 240 | ((cons local-variable null) 241 | (make-instance 'auxiliary-info 242 | :variable (first item))) 243 | ((cons local-variable (cons t null)) 244 | (make-instance 'auxiliary-info 245 | :variable (first item) 246 | :initform (second item))) 247 | (t (error "Invalid &aux lambda list item: ~S" 248 | item)))) 249 | 250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 251 | ;;; 252 | ;;; Lambda List Unparsing 253 | 254 | (defun unparse-ordinary-lambda-list 255 | (required optional rest-var keyword allow-other-keys-p auxiliary) 256 | (append 257 | (unparse-required required) 258 | (unparse-optional optional) 259 | (unparse-rest rest-var) 260 | (unparse-keyword keyword allow-other-keys-p) 261 | (unparse-auxiliary auxiliary))) 262 | 263 | (defun unparse-required (required) 264 | (mapcar 265 | (lambda (info) 266 | (required-info-variable info)) 267 | required)) 268 | 269 | (defun unparse-optional (optional) 270 | (if (null optional) 271 | `() 272 | `(&optional 273 | ,@(mapcar 274 | (lambda (info) 275 | `(,(optional-info-variable info) 276 | ,(optional-info-initform info) 277 | ,@(if (optional-info-suppliedp info) 278 | `(,(optional-info-suppliedp info)) 279 | `()))) 280 | optional)))) 281 | 282 | (defun unparse-keyword (keyword allow-other-keys-p) 283 | (if (and (null keyword) 284 | (not allow-other-keys-p)) 285 | `() 286 | `(&key 287 | ,@(mapcar 288 | (lambda (info) 289 | `((,(keyword-info-keyword info) ,(keyword-info-variable info)) 290 | ,(keyword-info-initform info) 291 | ,@(if (keyword-info-suppliedp info) 292 | `(,(keyword-info-suppliedp info)) 293 | `()))) 294 | keyword) 295 | ,@(if allow-other-keys-p 296 | '(&allow-other-keys) 297 | '())))) 298 | 299 | (defun unparse-rest (rest-var) 300 | (if (null rest-var) 301 | `() 302 | `(&rest ,rest-var))) 303 | 304 | (defun unparse-auxiliary (auxiliary) 305 | (if (null auxiliary) 306 | `() 307 | `(&aux 308 | ,@(mapcar 309 | (lambda (info) 310 | (list (auxiliary-info-variable info) 311 | (auxiliary-info-initform info))) 312 | auxiliary)))) 313 | 314 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 315 | ;;; 316 | ;;; Lambda List Info Anonymization 317 | 318 | (defun anonymize-ordinary-lambda-list (lambda-list) 319 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 320 | (parse-ordinary-lambda-list lambda-list) 321 | (unparse-ordinary-lambda-list 322 | (mapcar #'anonymize-required-info required) 323 | (mapcar #'anonymize-optional-info optional) 324 | (if (null rest-var) 325 | nil 326 | (gensymify rest-var)) 327 | (mapcar #'anonymize-keyword-info keyword) 328 | allow-other-keys-p 329 | (mapcar #'anonymize-auxiliary-info auxiliary)))) 330 | 331 | (defun anonymize-required-info (info) 332 | (make-instance 'required-info 333 | :variable (gensymify (required-info-variable info)))) 334 | 335 | (defun anonymize-optional-info (info) 336 | (make-instance 'optional-info 337 | :variable (gensymify (optional-info-variable info)) 338 | :initform (optional-info-initform info) 339 | :suppliedp (if (optional-info-suppliedp info) 340 | (gensymify (optional-info-suppliedp info)) 341 | nil))) 342 | 343 | (defun anonymize-keyword-info (info) 344 | (make-instance 'keyword-info 345 | :variable (gensymify (keyword-info-variable info)) 346 | :keyword (keyword-info-keyword info) 347 | :initform (keyword-info-initform info) 348 | :suppliedp (if (keyword-info-suppliedp info) 349 | (gensymify (keyword-info-suppliedp info)) 350 | nil))) 351 | 352 | (defun anonymize-auxiliary-info (info) 353 | (make-instance 'auxiliary-info 354 | :variable (gensymify (auxiliary-info-variable info)) 355 | :initform (auxiliary-info-initform info))) 356 | 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 358 | ;;; 359 | ;;; Miscellaneous 360 | 361 | (defun normalize-ordinary-lambda-list (lambda-list) 362 | (multiple-value-call #'unparse-ordinary-lambda-list 363 | (parse-ordinary-lambda-list lambda-list))) 364 | 365 | (defun lambda-list-variables (lambda-list) 366 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 367 | (parse-ordinary-lambda-list lambda-list) 368 | (declare (ignore allow-other-keys-p)) 369 | (let ((variables '())) 370 | (dolist (info required) 371 | (push (required-info-variable info) variables)) 372 | (dolist (info optional) 373 | (push (optional-info-variable info) variables) 374 | (when (optional-info-suppliedp info) 375 | (push (optional-info-suppliedp info) variables))) 376 | (unless (null rest-var) 377 | (push rest-var variables)) 378 | (dolist (info keyword) 379 | (push (keyword-info-variable info) variables) 380 | (when (keyword-info-suppliedp info) 381 | (push (keyword-info-suppliedp info) variables))) 382 | (dolist (info auxiliary) 383 | (push (auxiliary-info-variable info) variables)) 384 | (nreverse variables)))) 385 | 386 | (defun lambda-list-apply-arguments (lambda-list) 387 | (multiple-value-bind (required optional rest-var keyword) 388 | (parse-ordinary-lambda-list lambda-list) 389 | (append 390 | (mapcar #'required-info-variable required) 391 | (mapcar #'optional-info-variable optional) 392 | (if rest-var 393 | `(,rest-var) 394 | `(,@(loop for info in keyword 395 | collect (keyword-info-keyword info) 396 | collect (keyword-info-variable info)) 397 | '()))))) 398 | 399 | (defun compute-effective-method-lambda-list (generic-function applicable-methods) 400 | (multiple-value-bind (required optional rest-var keyword allow-other-keys) 401 | (parse-ordinary-lambda-list (generic-function-lambda-list generic-function)) 402 | (let ((method-parses 403 | (mapcar 404 | (lambda (method) 405 | (multiple-value-list 406 | (parse-ordinary-lambda-list 407 | (method-lambda-list method)))) 408 | applicable-methods))) 409 | (unparse-ordinary-lambda-list 410 | (merge-required-infos required (mapcar #'first method-parses)) 411 | (merge-optional-infos optional (mapcar #'second method-parses)) 412 | rest-var 413 | (merge-keyword-infos keyword (mapcar #'fourth method-parses)) 414 | (merge-allow-other-keys allow-other-keys (mapcar #'fifth method-parses)) 415 | '())))) 416 | 417 | (defun merge-required-infos (g-required m-requireds) 418 | (dolist (m-required m-requireds g-required) 419 | (assert (= (length m-required) 420 | (length g-required))))) 421 | 422 | (defun merge-optional-infos (g-optional m-optionals) 423 | (let ((n (length g-optional))) 424 | (dolist (m-optional m-optionals) 425 | (assert (= (length m-optional) n))) 426 | (unless (zerop n) 427 | (loop for g-info in g-optional 428 | for m-infos in (apply #'mapcar #'list m-optionals) 429 | collect 430 | ;; Now we have two cases - the one is that at least one method 431 | ;; cares about the suppliedp flag, the other one is that no 432 | ;; method cares. Even if a method doesn't reference the 433 | ;; suppliedp flag itself, it may still need it to decide whether 434 | ;; to supply its initform or not. Because of this, the suppliedp 435 | ;; parameter can only be discarded globally when the initforms of 436 | ;; all methods are constant and equal. 437 | (let ((global-initform (optional-info-initform (first m-infos))) 438 | (no-one-cares (not (optional-info-suppliedp (first m-infos))))) 439 | (dolist (m-info m-infos) 440 | (with-accessors ((variable optional-info-variable) 441 | (initform optional-info-initform) 442 | (suppliedp optional-info-suppliedp)) 443 | m-info 444 | (unless (and (constantp initform) 445 | (equal initform global-initform) 446 | (not suppliedp)) 447 | (setf no-one-cares nil)))) 448 | (if no-one-cares 449 | (make-instance 'optional-info 450 | :variable (optional-info-variable g-info) 451 | :initform global-initform) 452 | (make-instance 'optional-info 453 | :variable (optional-info-variable g-info) 454 | :initform nil 455 | :suppliedp (optional-info-suppliedp g-info)))))))) 456 | 457 | (defun merge-keyword-infos (g-keyword m-keywords) 458 | ;; First we assemble an alist whose keys are keywords and whose values 459 | ;; are all method keyword info objects that read this keyword. 460 | (let ((alist '())) 461 | (dolist (g-info g-keyword) 462 | (pushnew (list (keyword-info-keyword g-info)) alist)) 463 | (dolist (m-keyword m-keywords) 464 | (dolist (m-info m-keyword) 465 | (let* ((key (keyword-info-keyword m-info)) 466 | (entry (assoc key alist))) 467 | (if (consp entry) 468 | (push m-info (cdr entry)) 469 | (push (list key m-info) alist))))) 470 | (loop for (key . m-infos) in alist 471 | collect 472 | ;; Merging keyword info objects is handled just like in the case 473 | ;; of optional info objects above. 474 | (let ((global-initform (keyword-info-initform (first m-infos))) 475 | (no-one-cares (not (keyword-info-suppliedp (first m-infos)))) 476 | ;; Not actually g-info, but we need some place to grab a 477 | ;; variable name form. 478 | (g-info (or (find key g-keyword :key #'keyword-info-keyword) 479 | (first m-infos)))) 480 | (dolist (m-info m-infos) 481 | (with-accessors ((initform keyword-info-initform) 482 | (suppliedp keyword-info-suppliedp)) 483 | m-info 484 | (unless (and (constantp initform) 485 | (equal initform global-initform) 486 | (not suppliedp)) 487 | (setf no-one-cares nil)))) 488 | (if no-one-cares 489 | (make-instance 'keyword-info 490 | :keyword key 491 | :variable (keyword-info-variable g-info) 492 | :initform global-initform) 493 | (make-instance 'keyword-info 494 | :keyword key 495 | :variable (keyword-info-variable g-info) 496 | :initform nil 497 | :suppliedp (or (keyword-info-suppliedp g-info) 498 | (gensymify "SUPPLIEDP")))))))) 499 | 500 | (defun merge-allow-other-keys (g-allow-other-keys m-allow-other-keys-list) 501 | (reduce 502 | (lambda (a b) (or a b)) 503 | m-allow-other-keys-list 504 | :initial-value g-allow-other-keys)) 505 | -------------------------------------------------------------------------------- /optimization.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defun specializer-lists (methods) 4 | (let ((gf (method-generic-function (first methods)))) 5 | (loop for position below (length (generic-function-argument-precedence-order gf)) 6 | collect 7 | (let ((leaf-classes '())) 8 | (loop for method in methods do 9 | (let ((specializer (elt (method-specializers method) position))) 10 | (loop for lc in (class-leaf-subclasses specializer) do 11 | (pushnew lc leaf-classes)))) 12 | leaf-classes)))) 13 | 14 | (defmethod compute-effective-method-function 15 | ((julia-function julia-function) effective-method options) 16 | (let* ((name (generic-function-name julia-function)) 17 | (methods (generic-function-methods julia-function)) 18 | (lambda-list 19 | (anonymize-ordinary-lambda-list 20 | ;; Unfortunately, we don't know the list of applicable methods 21 | ;; anymore at this stage. So instead, we consider all methods 22 | ;; applicable. 23 | (compute-effective-method-lambda-list julia-function methods)))) 24 | (compile 25 | nil 26 | `(lambda ,lambda-list 27 | (declare (ignorable ,@lambda-list)) 28 | ,(labels ((expand (position specializer-lists specializers) 29 | (if (null specializer-lists) 30 | `(funcall (ensure-julia-emf-defun #',name ',(mapcar #'class-name (reverse specializers))) 31 | ;; TODO 32 | ,@lambda-list) 33 | `(etypecase ,(nth position lambda-list) 34 | ,@(loop for specializer in (first specializer-lists) 35 | collect 36 | `(,(class-name specializer) 37 | ,(expand (1+ position) 38 | (rest specializer-lists) 39 | (cons specializer specializers)))))))) 40 | (expand 0 (specializer-lists methods) '())))))) 41 | 42 | (defvar *last-emf-defun*) 43 | 44 | (defun compute-julia-emf-defun (julia-function class-names) 45 | (let* ((name (gensym "JULIA-EMF-")) 46 | (signature (mapcar #'find-class class-names)) 47 | (prototypes (mapcar #'class-prototype signature)) 48 | (applicable-methods (compute-applicable-methods julia-function prototypes)) 49 | (lambda-list 50 | (anonymize-ordinary-lambda-list 51 | (compute-effective-method-lambda-list julia-function applicable-methods)))) 52 | (eval 53 | (setf *last-emf-defun* 54 | `(progn 55 | (declaim (inline ,name)) 56 | (defun ,name ,lambda-list 57 | (declare (optimize (speed 3) (safety 0) (debug 0) (space 0) (compilation-speed 0))) 58 | ,@(loop for specializer in signature 59 | for argument in lambda-list 60 | collect `(declare (type ,(class-name specializer) ,argument))) 61 | ,(expand-effective-method-body 62 | (compute-effective-method 63 | julia-function 64 | (generic-function-method-combination julia-function) 65 | applicable-methods) 66 | julia-function lambda-list))))))) 67 | 68 | (defun ensure-julia-emf-defun (julia-function signature) 69 | (alexandria:ensure-gethash 70 | signature 71 | (julia-function-emf-defuns julia-function) 72 | (compute-julia-emf-defun julia-function signature))) 73 | 74 | (defmethod shared-initialize :after 75 | ((julia-function julia-function) (slot-names t) &key &allow-other-keys) 76 | (declare (ignore slot-names)) 77 | (clrhash (julia-function-emf-defuns julia-function)) 78 | (let ((name (generic-function-name julia-function))) 79 | ;; Ensure that the function is known to SBCL. 80 | (unless (sb-c::info :function :info name) 81 | (eval `(sb-c:defknown ,name * * ()))))) 82 | 83 | (defmethod add-method :after 84 | ((julia-function julia-function) 85 | (julia-method julia-method)) 86 | (mapc 87 | (lambda (specializers) 88 | (let ((name (generic-function-name julia-function)) 89 | (types (mapcar #'class-name specializers))) 90 | (handler-case 91 | (eval 92 | `(sb-c:deftransform ,name ((&rest args) (,@types)) 93 | (optimize-julia-function-call #',name ',types))) 94 | (sb-kernel:redefinition-with-deftransform () (values))))) 95 | (apply 96 | #'alexandria:map-product 97 | #'list 98 | (specializer-lists (generic-function-methods julia-function))))) 99 | 100 | (defun optimize-julia-function-call (julia-function signature) 101 | `(lambda (&rest args) 102 | (apply #',(ensure-julia-emf-defun julia-function signature) args))) 103 | 104 | (defmethod make-method-lambda :around 105 | ((gf julia-function) 106 | (julia-method julia-method) 107 | lambda 108 | environment) 109 | (multiple-value-bind (method-lambda initargs) 110 | (call-next-method) 111 | (values 112 | method-lambda 113 | (list* 114 | '.lambda. 115 | (make-julia-method-lambda gf julia-method lambda environment) 116 | initargs)))) 117 | 118 | (defun make-julia-method-lambda 119 | (generic-function method lambda environment) 120 | (declare (ignore method)) 121 | (destructuring-bind (lambda-symbol lambda-list &rest body) lambda 122 | (assert (eql lambda-symbol 'lambda)) 123 | (multiple-value-bind (required optional rest-var keyword allow-other-keys-p auxiliary) 124 | (parse-ordinary-lambda-list lambda-list) 125 | (multiple-value-bind (forms declarations) 126 | (alexandria:parse-body body) 127 | (let ((partially-flattened-lambda-list 128 | `(,@(lambda-list-variables 129 | (unparse-ordinary-lambda-list 130 | required optional rest-var keyword allow-other-keys-p '())) 131 | ,@(unparse-ordinary-lambda-list '() '() nil '() nil auxiliary)))) 132 | (trivial-macroexpand-all:macroexpand-all 133 | `(lambda ,partially-flattened-lambda-list 134 | (declare (ignorable ,@(mapcar #'required-info-variable required))) 135 | ,@declarations 136 | (block ,(block-name (generic-function-name generic-function)) 137 | ,@forms)) 138 | environment)))))) 139 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (defpackage #:julia-functions 4 | (:use 5 | #:closer-common-lisp) 6 | 7 | (:export 8 | #:julia-function 9 | #:julia-method)) 10 | -------------------------------------------------------------------------------- /utilities.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:julia-functions) 2 | 3 | (defun block-name (function-name) 4 | (etypecase function-name 5 | ((and symbol (not null)) function-name) 6 | ((cons (eql setf) (cons symbol null)) (second function-name)))) 7 | 8 | (defun null-lexical-environement-p (environment) 9 | (declare (ignorable environment)) 10 | (or (null environment) 11 | #+sbcl (sb-c::null-lexenv-p environment))) 12 | 13 | (defgeneric gensymify (object) 14 | (:method ((string string)) 15 | (gensym (string-upcase (concatenate 'string string "-")))) 16 | (:method ((symbol symbol)) 17 | (if (null (symbol-package symbol)) 18 | ;; If we are dealing with uninterned symbols, we strip any 19 | ;; non-alphanumeric characters. This has the effect that 20 | ;; gensymification of gensyms doesn't just add more and more 21 | ;; digits and hypens. 22 | (let ((name (symbol-name symbol))) 23 | (gensymify (subseq name 0 (1+ (position-if #'alpha-char-p name :from-end t))))) 24 | (gensymify (symbol-name symbol)))) 25 | (:method ((object t)) 26 | (gensymify (princ-to-string object)))) 27 | 28 | (defun class-subclasses (class) 29 | (let ((table (make-hash-table))) 30 | (labels ((rec (class) 31 | (unless (gethash class table) 32 | (setf (gethash class table) t) 33 | (mapc #'rec (class-direct-subclasses class))))) 34 | (rec class)) 35 | (loop for c being the hash-keys of table collect c))) 36 | 37 | (defun class-leaf-subclasses (class) 38 | (remove-if #'class-direct-subclasses (class-subclasses class))) 39 | 40 | --------------------------------------------------------------------------------