gen.lisp

(sb-int:set-floating-point-modes  :traps '(:overflow  :invalid :divide-by-zero))
;;; ================================================================
;;; 1. CONFIGURATION & GRAMMAR
;;; ================================================================
(defvar *integer-types* '(integer fixnum
                          (unsigned-byte #.sb-vm:n-word-bits)
                          (signed-byte #.sb-vm:n-word-bits)
                          (and fixnum unsigned-byte)
                          (integer * 0)
                          (integer * -1)
                          (integer 1)
                          unsigned-byte
                          (and fixnum (integer * 0))
                          (and fixnum (integer * -1))
                          (and fixnum (integer * -1))
                          (and fixnum (integer 1))))
(defparameter *types* (list* 'single-float 'boolean *integer-types*))
(defparameter *max-depth* 5)

(defparameter *operators*
  `(;; Integer
    (+   (integer integer)     integer)
    (-   (integer integer)     integer)
    (-   (integer)     integer)
    (*   (integer integer)     integer)
    (truncate (integer integer) integer)
    (floor (integer integer) integer)
    (ceiling (integer integer) integer)
    (round (integer integer) integer)
    
    (logand (integer integer) integer)
    (logxor (integer integer) integer)
    (logior (integer integer) integer)
    (lognot (integer) integer)
    (integer-length (integer) integer)
    (logcount (integer) integer)
    (max (integer integer) integer)
    (min (integer integer) integer)
    (abs (integer) integer)
    (evenp (integer) boolean)
    (oddp (integer) boolean)



    ;; Comparison
    (>   (integer integer)           boolean)
    (<   (integer integer)           boolean)
    (=   (integer integer)           boolean)
    
    
    ;; Logic
    (and (boolean boolean) boolean)
    (or  (boolean boolean) boolean)
    (not (boolean)         boolean)

    #-(and arm64 (not darwin))
    ,@'(;; Float
        (+   (single-float single-float) single-float)
        (-   (single-float single-float) single-float)
        (-   (single-float) single-float)
        (*   (single-float single-float) single-float)
        (/   (single-float single-float) single-float)
        (truncate (single-float single-float) integer)
        (ceiling (single-float single-float) integer)
        (round (single-float single-float) integer)

        (ffloor (single-float single-float) single-float)
        (ftruncate (single-float single-float) single-float)
        (fceiling (single-float single-float) single-float)
        (fround (single-float single-float) single-float)
        (ffloor (single-float single-float) single-float)

        (max (single-float single-float) single-float)
        (min (single-float single-float) single-float)
        (abs (single-float) single-float)

        (sin (single-float) single-float)
        (sin (integer) single-float)
        (cos (single-float) single-float)
        (cos (integer) single-float)

        (+   (single-float integer) single-float)
        (-   (single-float integer) single-float)
        (*   (single-float integer) single-float)
        (/   (single-float integer) single-float)

        (>   (single-float single-float) boolean)
        (<   (single-float single-float) boolean))))

;;; ================================================================
;;; 2. GENERATOR
;;; ================================================================

(defun random-elt (seq)
  (if (null seq) nil (elt seq (random (length seq)))))


(defun get-ops (ret-type)
  (when (member ret-type *integer-types* :test #'eq)
    (setf ret-type 'integer))
  (remove-if-not (lambda (x) (eq (third x) ret-type)) *operators*))

(defun get-vars (ret-type schema)
  (mapcar #'car (remove-if-not (lambda (x) (eq (cdr x) ret-type)) schema)))

(defconstant max-integer (1- sb-vm:n-fixnum-bits))

(defun random-const (type)
  (case type
    (integer (* (if (< (random 100) 30)
                    (random 100)
                    (random (expt 2 max-integer)))
                (if (zerop (random 2)) 1 -1)))
    (unsigned-byte (if (< (random 100) 30)
                       (random 100)
                       (random (expt 2 max-integer))))
    (single-float (+ (random 50.0) 0.5))
    (boolean      (if (zerop (random 2)) nil t))
    (fixnum (* (random (if (< (random 100) 50)
                           (1+ (random 100))
                           (expt 2 #.(1- sb-vm:n-fixnum-bits))))
               (if (zerop (random 2)) 1 -1)))
    (t
     (cond ((equal type '(signed-byte #.sb-vm:n-word-bits))
            (* (if (< (random 100) 50)
                   (1+ (random 100))
                   (random (expt 2 #.(1- sb-vm:n-word-bits))))
               (if (zerop (random 2)) 1 -1)))
           ((equal type '(unsigned-byte #.sb-vm:n-word-bits))
            (random (if (< (random 100) 50)
                        (1+ (random 100))
                        (expt 2 #.sb-vm:n-word-bits))))
           ((equal type '(and fixnum unsigned-byte))
            (random (if (< (random 100) 50)
                        (1+ (random 100))
                        (expt 2 #.(1- sb-vm:n-fixnum-bits)))))
           ((equal type '(integer * 0))
            (- (if (< (random 100) 30)
                   (random 100)
                   (random (expt 2 max-integer)))))
           ((equal type '(integer * -1))
            (- -1 (if (< (random 100) 30)
                      (random 100)
                      (random (expt 2 max-integer)))))
           ((equal type '(and fixnum (integer * -1)))
            (- -1 (if (< (random 100) 30)
                      (random 100)
                      (random (expt 2 #.(1- sb-vm:n-fixnum-bits))))))
           ((equal type '(and fixnum (integer * 0)))
            (- (if (< (random 100) 30)
                   (random 100)
                   (random (expt 2 #.(1- sb-vm:n-fixnum-bits))))))
           ((equal type '(and fixnum (integer 1)))
            (1+ (if (< (random 100) 30)
                    (random 100)
                    (random (1- (expt 2 #.(1- sb-vm:n-fixnum-bits)))))))
           ((equal type '(integer 1)) 
            (1+ (if (< (random 100) 30)
                    (random 100)
                    (random (expt 2 max-integer)))))))))

(defun generate-ast (type depth schema)
  (let ((terminals '(const))
        (vars (get-vars type schema))
        (funcs (get-ops type)))
    (when vars (push 'var terminals))
    (let* ((stop (>= depth *max-depth*))
           (options (if stop terminals (append terminals '(func if)))))
      (case (random-elt options)
        (const (random-const type))
        (var   (random-elt vars))
        (if    (list 'if 
                     (generate-ast 'boolean (1+ depth) schema)
                     (generate-ast type (1+ depth) schema)
                     (generate-ast type (1+ depth) schema)))
        (func  (if (null funcs) 
                   (random-const type)
                   (let ((op (random-elt funcs)))
                     (cons (first op)
                           (loop for arg-t in (second op)
                                 collect (generate-ast arg-t (1+ depth) schema))))))))))

(defun build-random-function (target-type)
  (let ((schema (loop for i from 1 to 3 
                      collect (cons (intern (format nil "V~d" i)) 
                                    (random-elt *types*)))))
    (let ((body (generate-ast target-type 0 schema))
          (vars (mapcar #'car schema)))
      (values 
       `(lambda ,vars
          (declare (ignorable ,@vars))
          ,@(progn;if (> (random 100) 90)
                (loop for (v . t-name) in schema
                      collect `(declare (type ,(if nil;(> (random 100) 60)
                                                   t
                                                   t-name) ,v))))
          (declare (optimize (safety 1) (speed 3))) 
          ,body)
       schema))))

;;; ================================================================
;;; 3. EXECUTION & COMPARISON
;;; ================================================================

(defun values-match-p (val1 val2)
  (cond
    ;; ((and (typep val1 'single-float) (typep val2 'single-float))
    ;;  (< (abs (- val1 val2)) 0.001))
    (t (and (= (length val1) (length val2))
            (loop for v1 in val1
                  for v2 in val2
                  always (or (eql v1 v2)
                             #+(and arm64 (not darwin))
                             (or (and (floatp v1) (sb-ext:float-nan-p v1))
                                 (and (floatp v2)
                                      (sb-ext:float-nan-p v2)))
                             ;; MINUS-ZERO
                             ;; (and (or (eql v1 0.0)
                             ;;          (eql v2 0.0))
                             ;;      (= v1 v2))
                             #-(and arm64 (not darwin))
                             (and (and (floatp v1)
                                       (sb-ext:float-nan-p v1))
                                  (and (floatp v2)
                                       (sb-ext:float-nan-p v2)))))))))

(defun safe-execute (code func)
  "Returns (values result condition)"
  (handler-case
      (handler-bind ((sb-sys:memory-fault-error (lambda (c)
                                                  (with-standard-io-syntax 
                                                    (princ code))
                                                  (break "~a" c))))
        (values (multiple-value-list (funcall func)) nil))
    (error (c) (values nil c))))

(defun report-error (reason code inputs c-res i-res)
  (format t "~%!!! DETECTED DISCREPANCY !!!")
  (format t "~%Reason: ~A" reason)
  (format t "~%Code: ~S" code)
  (format t "~%Inputs: ~A" inputs)
  (format t "~%Compiled Result: ~A" c-res)
  (format t "~%Interpret Result: ~A" i-res)
  (format t "~%--------------------------------------------------")
  (error "~a ~a" code inputs))

(defun is-div-zero (err)
  (typep err '(or floating-point-invalid-operation
               floating-point-overflow
               division-by-zero)))

(defun run-test ()
  (let ((target (random-elt *types*)))
    (multiple-value-bind (code schema) (build-random-function target)
      (let ((fn (handler-bind (((or sb-ext:code-deletion-note sb-ext:compiler-note style-warning warning) #'muffle-warning))
                  (multiple-value-bind (fun warn fail) (compile nil code)
                    (declare (ignore warn fail))
                    ;; (when fail
                    ;;   (error "~a" code))
                    fun))))
        
        (loop repeat 1000 
              do

              (let ((inputs (loop for (_ . t-name) in schema
                                  collect (random-const t-name))))
                (multiple-value-bind (c-val c-err) (safe-execute code
                                                                 (lambda () 
                                                                   (apply fn inputs)))
                  ;; 2. Run Interpreted
                  (multiple-value-bind (i-val i-err)
                      (safe-execute (cons 'i code) 
                                    (lambda ()
                                      #+sbcl
                                      (let ((sb-ext:*evaluator-mode* :interpret))
                                        (apply (eval code) inputs))
                                      #-sbcl
                                      (apply (eval code) inputs)))

                    ;; 3. Compare (Filtering Logic)
                    (cond
                      ;; A. If either failed due to Div-By-Zero, Ignore completely.
                      ((or (is-div-zero c-err) (is-div-zero i-err))
                       nil)

                      ;; B. Both Succeeded: Check Values
                      ((and (not c-err) (not i-err))
                       (unless (values-match-p c-val i-val)
                         (report-error "VALUE MISMATCH" code inputs c-val i-val)))

                      ;; C. Both Errored (Non-DivZero): Check Error Types match
                      ((and c-err i-err)
                       (unless (eq (type-of c-err) (type-of i-err))
                         (report-error "ERROR TYPE MISMATCH" code inputs c-err i-err)))

                      ;; D. One Error, One Success (Non-DivZero)
                      (t
                       (report-error "STATUS MISMATCH (One Error/One Value)" 
                                     code inputs (or c-err c-val) (or i-err i-val))))))))))))

;;; ================================================================
;;; 4. MAIN LOOP
;;; ================================================================

(defun main (&optional (threads 12))
  (setf *random-state* (make-random-state t))
  (let ((threads
          (loop repeat threads
                collect
                (sb-thread:make-thread
                 (lambda ()
                   (loop
                    (run-test)))
                 :name "random"))))
    (unwind-protect (mapcar (lambda (th)
                              (sb-thread:join-thread th :default nil)) threads)
         (mapcar (lambda (th)
                   (ignore-errors (sb-thread:terminate-thread th)))
                 threads))))