diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index a1c5adc71..dc0a1457e 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -490,6 +490,33 @@ (define-primitive-expander f64vector-set! (vec i x) (bytevector-ieee-double-native-set! vec (* i 8) x)) +(hashq-set! *primitive-expand-table* + 'equal? + (case-lambda + ((src a b) + ;; Simplify cases where either A or B is constant. + (define (maybe-simplify a b) + (and (const? a) + (let ((v (const-exp a))) + (cond + ((eq? #f v) + (make-application src (make-primitive-ref #f 'not) + (list b))) + ((eq? '() v) + (make-application src (make-primitive-ref #f 'null?) + (list b))) + ((or (eq? #t v) + (eq? #nil v) + (symbol? v) + (and (integer? v) + (<= v most-positive-fixnum) + (>= v most-negative-fixnum))) + (make-application src (make-primitive-ref #f 'eq?) + (list a b))) + (else #f))))) + (or (maybe-simplify a b) (maybe-simplify b a))) + (else #f))) + (hashq-set! *primitive-expand-table* 'dynamic-wind (case-lambda diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 4ffdce09e..bb7f90863 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -58,6 +58,20 @@ (assert-tree-il->glil with-partial-evaluation in pat test ...)))) +(define-syntax-rule (pass-if-primitives-resolved in expected) + (pass-if (format #f "primitives-resolved in ~s" 'in) + (let* ((module (let ((m (make-module))) + (beautify-user-module! m) + m)) + (orig (parse-tree-il 'in)) + (resolved (expand-primitives! (resolve-primitives! orig module)))) + (or (equal? (unparse-tree-il resolved) 'expected) + (begin + (format (current-error-port) + "primitive test failed: got ~s, expected ~s" + resolved 'expected) + #f))))) + (define-syntax pass-if-tree-il->scheme (syntax-rules () ((_ in pat) @@ -69,6 +83,33 @@ (pat (guard guard-exp) #t) (_ #f)))))) + +(with-test-prefix "primitives" + + (pass-if-primitives-resolved + (apply (primitive equal?) (toplevel x) (const #f)) + (apply (primitive not) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (toplevel x) (const ())) + (apply (primitive null?) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #t) (lexical x y)) + (apply (primitive eq?) (const #t) (lexical x y))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) + (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const 42) (toplevel x)) + (apply (primitive eq?) (const 42) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #nil) (toplevel x)) + (apply (primitive eq?) (const #nil) (toplevel x)))) + (with-test-prefix "tree-il->scheme" (pass-if-tree-il->scheme @@ -1704,3 +1745,8 @@ #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unsupported format option")))))))) + +;; Local Variables: +;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1) +;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1) +;; End: