From aab3325de8ea909e800920e16df83fcf52440940 Mon Sep 17 00:00:00 2001 From: shubhamkar Date: Thu, 23 Nov 2023 21:26:41 +0530 Subject: [PATCH] Add type inference for several number functions --- src/cl-functions.lisp | 159 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 159 insertions(+) diff --git a/src/cl-functions.lisp b/src/cl-functions.lisp index 1711728..fd19e6b 100644 --- a/src/cl-functions.lisp +++ b/src/cl-functions.lisp @@ -171,3 +171,162 @@ (maybe-constant-form-value type env :default t)) (_ t))) + +(defstruct (numeric-op (:conc-name %numeric-op-)) + closed-under-fixnum-p + closed-under-integers-p + closed-under-rationals-p + closed-under-float-p + result-necessarily-float-p + result-necessarily-integer-p + result-necessarily-real-p) + +(macrolet ((def (slot-name) + `(defun ,(symbolicate 'numeric-op '- slot-name) (op) + (multiple-value-bind (value existsp) + (gethash op *numeric-op-table*) + (if existsp + (,(symbolicate '%numeric-op- slot-name) value) + nil))))) + (def closed-under-fixnum-p) + (def closed-under-integers-p) + (def closed-under-rationals-p) + (def closed-under-float-p) + (def result-necessarily-float-p) + (def result-necessarily-integer-p) + (def result-necessarily-real-p)) + +(defparameter *numeric-op-table* + (alist-hash-table + (nconc + (list (cons '+ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t)) + (cons '- (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t)) + (cons '* (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t)) + (cons '/ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p t :closed-under-float-p t)) + + (cons '1+ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t)) + (cons '1- (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t))) + + #+sbcl + (list (cons 'max (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t :result-necessarily-real-p t)) + (cons 'min (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t :result-necessarily-real-p t))) + + ;; Implementations are free to decide whether to apply contagions or not: http://clhs.lisp.se/Body/f_max_m.htm + #-sbcl + (list (cons 'max (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p nil :closed-under-float-p nil :result-necessarily-real-p t)) + (cons 'min (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p nil :closed-under-float-p nil :result-necessarily-real-p t))) + + (list (cons 'floor (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t)) + (cons 'ceiling (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t)) + (cons 'truncate (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t)) + (cons 'round (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t)) + + (cons 'ffloor (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t)) + (cons 'fceiling (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t)) + (cons 'ftruncate (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t)) + (cons 'fround (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t))) + + #+sbcl + (list (cons 'sin (make-numeric-op :result-necessarily-float-p t)) + (cons 'cos (make-numeric-op :result-necessarily-float-p t)) + (cons 'tan (make-numeric-op :result-necessarily-float-p t))) + #-sbcl + (list (cons 'sin (make-numeric-op)) + (cons 'cos (make-numeric-op)) + (cons 'tan (make-numeric-op)))))) + +(defun numeric-result-type (op arg-types env) + + (flet ((some-subtypep (type) + (some (lambda (arg-type) + (subtypep arg-type type env)) + arg-types)) + (all-subtypep (type) + (every (lambda (arg-type) + (subtypep arg-type type env)) + arg-types))) + + (let* ((realp (numeric-op-result-necessarily-real-p op)) + (complex-possible-p (not realp))) + + (when (numeric-op-closed-under-fixnum-p op) + (when (all-subtypep 'fixnum) + (return-from numeric-result-type 'fixnum)) + (when (and complex-possible-p + (all-subtypep '(complex fixnum))) + (return-from numeric-result-type '(complex fixnum)))) + + (when (numeric-op-closed-under-integers-p op) + (when (all-subtypep 'integer) + (return-from numeric-result-type 'integer)) + (when (and complex-possible-p + (all-subtypep '(complex integer))) + (return-from numeric-result-type '(complex integer)))) + + (when (numeric-op-closed-under-rationals-p op) + (when (all-subtypep 'rational) + (return-from numeric-result-type 'rational)) + (when (and complex-possible-p + (all-subtypep '(complex rational))) + (return-from numeric-result-type '(complex rational)))) + + (when (numeric-op-closed-under-float-p op) + (when (all-subtypep 'single-float) + (return-from numeric-result-type 'single-float)) + (when (all-subtypep 'double-float) + (return-from numeric-result-type 'double-float)) + + (when complex-possible-p + (when (all-subtypep '(complex single-float)) + (return-from numeric-result-type '(complex single-float))) + (when (all-subtypep '(complex double-float)) + (return-from numeric-result-type '(complex double-float))))) + + (when (numeric-op-result-necessarily-integer-p op) + (return-from numeric-result-type 'integer)) + + (when (numeric-op-result-necessarily-float-p op) + (when (some-subtypep 'double-float) + (return-from numeric-result-type 'double-float)) + ;; What happens if all the results are rational? + (return-from numeric-result-type 'single-float)) + + (return-from numeric-result-type 'number)))) + +(defun every-eql-type-p (types env) + (let (values) + (every (lambda (type) + (optima:match (peltadot/types-core:typexpand type env) + ((list 'eql value) + (push value values)) + (_ + (return-from every-eql-type-p + (values nil nil))))) + types) + (values t (nreverse values)))) + +(defun numeric-op-form-type (op args env) + (let ((arg-types (mapcar (lambda (arg) + (introspect-environment:typexpand + (form-type arg env) + env)) + args))) + (multiple-value-bind (all-eql-p values) + (every-eql-type-p arg-types env) + (cond (all-eql-p + (or (ignore-errors `(eql ,(apply op values))) + `number)) + (t + (numeric-result-type op arg-types env)))))) + +(macrolet ((def (&rest ops) + `(progn + ,@(mapcar (lambda (op) + `(defmethod custom-form-type ((op (eql ',op)) args env) + (numeric-op-form-type op args env))) + ops)))) + (def + - / * 1+ 1- max min + floor ceiling truncate round + ffloor fceiling fruncate fround + + sin cos tan atan))