mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-14 05:12:38 -08:00
282 lines
11 KiB
Common Lisp
282 lines
11 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
|
|
;;;;
|
|
;;;; CMPOPT-SEQUENCE Optimization of SEQUENCE functions
|
|
;;;;
|
|
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun constant-function-expression (form)
|
|
(and (consp form)
|
|
(member (first form) '(quote function lambda))))
|
|
|
|
(defun seq-opt-test-function (test-flag test)
|
|
(cond ((null test-flag)
|
|
(values (seq-opt-test-function :test '#'eql) nil))
|
|
((eq test-flag :test-not)
|
|
(multiple-value-bind (function init)
|
|
(seq-opt-test-function :test test)
|
|
(values #'(lambda (v1 v2) `(not ,(funcall function v1 v2)))
|
|
init)))
|
|
((constant-function-expression test)
|
|
(values #'(lambda (v1 v2) `(funcall ,test ,v1 ,v2))
|
|
nil))
|
|
(t
|
|
(ext:with-unique-names (test-function)
|
|
(values #'(lambda (v1 v2) `(funcall ,test-function ,v1 ,v2))
|
|
(list (list test-function test)))))))
|
|
|
|
(defun seq-opt-key-function (key)
|
|
(cond ((null key)
|
|
(values #'identity nil))
|
|
((constant-function-expression key)
|
|
(values #'(lambda (elt) `(funcall ,key ,elt))
|
|
nil))
|
|
(t
|
|
(ext:with-unique-names (key-function)
|
|
(values #'(lambda (elt) `(funcall ,key-function ,elt))
|
|
(list (list key-function
|
|
`(or ,key #'identity))))))))
|
|
|
|
(defun seq-opt-parse-args (function args &key (start-end t))
|
|
(loop with key-flag = nil
|
|
with key = nil
|
|
with init = nil
|
|
with test = ''eql
|
|
with test-flag = nil
|
|
with start = 0
|
|
with end = nil
|
|
with keyword
|
|
while args
|
|
do (cond ((or (atom args)
|
|
(null (rest args))
|
|
(eq keyword :allow-other-keys)
|
|
(not (keywordp (setf keyword (pop args)))))
|
|
(return nil))
|
|
((eq keyword :key)
|
|
(unless key-flag
|
|
(setf key (pop args)
|
|
key-flag t)))
|
|
((or (eq keyword :test)
|
|
(eq keyword :test-not))
|
|
(cond ((null test-flag)
|
|
(setf test (pop args)
|
|
test-flag keyword))
|
|
((not (eq test-flag keyword))
|
|
(cmpwarn "Cannot specify :TEST and :TEST-NOT arguments to ~A"
|
|
function)
|
|
(return nil))))
|
|
((eq keyword :start)
|
|
(unless start-end
|
|
(cmpwarn "Unexpected keyword argument ~A in a call to function ~A"
|
|
keyword function)
|
|
(return nil))
|
|
(setf start (pop args)))
|
|
((eq keyword :end)
|
|
(unless start-end
|
|
(cmpwarn "Unexpected keyword argument ~A in a call to function ~A"
|
|
keyword function)
|
|
(return nil))
|
|
(setf end (pop args)))
|
|
((eq keyword :from-end)
|
|
(unless (null (pop args))
|
|
(return nil)))
|
|
(t (return nil)))
|
|
finally
|
|
(multiple-value-bind (key-function key-init)
|
|
(seq-opt-key-function key)
|
|
(multiple-value-bind (test-function test-init)
|
|
(seq-opt-test-function test-flag test)
|
|
(return (values key-function
|
|
test-function
|
|
(nconc key-init test-init)
|
|
key-flag
|
|
test-flag
|
|
test))))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro ext::make-seq-iterator (seq &optional (start 0))
|
|
(with-clean-symbols (%seq %start)
|
|
`(let ((%seq (optional-type-check ,seq sequence))
|
|
(%start ,start))
|
|
(cond ((consp %seq)
|
|
(nthcdr %start %seq))
|
|
((< %start (length %seq))
|
|
%start)
|
|
(t
|
|
nil)))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro ext::seq-iterator-ref (seq iterator)
|
|
(with-clean-symbols (%seq %iterator)
|
|
`(let* ((%seq ,seq)
|
|
(%iterator ,iterator))
|
|
(declare (optimize (safety 0)))
|
|
(if (si::fixnump %iterator)
|
|
;; Fixnum iterators are always fine
|
|
(aref %seq %iterator)
|
|
;; Error check in case we may have been passed an improper list
|
|
(cons-car (assert-type-if-known %iterator cons))))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro ext::seq-iterator-next (seq iterator)
|
|
(with-clean-symbols (%seq %iterator)
|
|
`(let* ((%seq ,seq)
|
|
(%iterator ,iterator))
|
|
(declare (optimize (safety 0)))
|
|
(if (si::fixnump %iterator)
|
|
(let ((%iterator (1+ (the fixnum %iterator))))
|
|
(declare (fixnum %iterator))
|
|
(and (< %iterator (length (the vector %seq)))
|
|
%iterator))
|
|
(cons-cdr %iterator)))))
|
|
|
|
(defmacro do-in-seq ((%elt sequence &key (start 0) end output) &body body)
|
|
(ext:with-unique-names (%start %iterator %counter %sequence)
|
|
(let* ((counter (and end `(- (or ,end most-positive-fixnum)
|
|
,%start)))
|
|
(test (if end
|
|
`(and ,%iterator (plusp ,%counter))
|
|
%iterator)))
|
|
`(let* ((,%sequence ,sequence)
|
|
(,%start ,start)
|
|
(,%iterator (ext::make-seq-iterator ,%sequence ,%start))
|
|
(,%counter ,counter))
|
|
(declare (:read-only ,%sequence ,%start ,%counter)
|
|
(ignorable ,%counter)
|
|
(fixnum ,%counter))
|
|
(loop
|
|
(unless ,test (return ,output))
|
|
(let ((,%elt (ext::seq-iterator-ref ,%sequence ,%iterator)))
|
|
,@body)
|
|
(setf ,%iterator (ext::seq-iterator-next ,%sequence ,%iterator)))))))
|
|
|
|
;;;
|
|
;;; MEMBER
|
|
;;;
|
|
|
|
(defmacro do-in-list ((%elt %sublist list &rest output) &body body)
|
|
`(do* ((,%sublist ,list (cons-cdr ,%sublist)))
|
|
((null ,%sublist) ,@output)
|
|
(let* ((,%sublist (optional-type-check ,%sublist cons))
|
|
(,%elt (cons-car ,%sublist)))
|
|
,@body)))
|
|
|
|
(defun expand-member (value list &rest sequence-args)
|
|
(multiple-value-bind (key-function test-function init
|
|
key-flag test-flag test)
|
|
(seq-opt-parse-args 'member sequence-args :start-end nil)
|
|
(unless key-flag
|
|
#+(or)
|
|
(when (and (or (null test) (constant-function-expression test))
|
|
(constant-expression-p list))
|
|
(when (<= (length (setf list (cmp-eval list))) 4)
|
|
(return-from expand-member
|
|
(ext:with-unique-names (%value)
|
|
`(let ((,%value ,value))
|
|
(or ,@(loop for l on list
|
|
for elt = (first l)
|
|
collect `(and ,(funcall test-function %value `',elt)
|
|
',l))))))
|
|
(when (or (consp list) (symbol list))
|
|
(setf list `',list))))
|
|
(when (or (null test-flag) (eq test-flag :test))
|
|
(when (member test '('EQ #'EQ) :test #'equal)
|
|
(return-from expand-member
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"si_memq(#0,#1)" :one-liner t :side-effects nil)))
|
|
(when (member test '('EQL #'EQL) :test #'equal)
|
|
(return-from expand-member
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_memql(#0,#1)" :one-liner t :side-effects nil)))
|
|
(when (member test '('EQUAL #'EQUAL) :test #'equal)
|
|
(return-from expand-member
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_member(#0,#1)" :one-liner t :side-effects nil)))))
|
|
(when test-function
|
|
(ext:with-unique-names (%value %sublist %elt)
|
|
`(let ((,%value ,value)
|
|
,@init)
|
|
(do-in-list (,%elt ,%sublist ,list)
|
|
(when ,(funcall test-function %value
|
|
(funcall key-function %elt))
|
|
(return ,%sublist))))))))
|
|
|
|
(define-compiler-macro member (&whole whole value list &rest sequence-args)
|
|
(if (policy-inline-sequence-functions)
|
|
(or (apply #'expand-member (rest whole))
|
|
whole)
|
|
whole))
|
|
|
|
;;;
|
|
;;; ASSOC
|
|
;;;
|
|
|
|
(defun expand-assoc (value list &rest sequence-args)
|
|
(multiple-value-bind (key-function test-function init
|
|
key-flag test-flag test)
|
|
(seq-opt-parse-args 'member sequence-args :start-end nil)
|
|
(unless key-flag
|
|
(when (or (null test-flag) (eq test-flag :test))
|
|
(when (member test '('EQ #'EQ) :test #'equal)
|
|
(return-from expand-assoc
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_assq(#0,#1)" :one-liner t :side-effects nil)))
|
|
(when (member test '('EQL #'EQL) :test #'equal)
|
|
(return-from expand-assoc
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_assql(#0,#1)" :one-liner t :side-effects nil)))
|
|
(when (member test '('EQUAL #'EQUAL) :test #'equal)
|
|
(return-from expand-assoc
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_assoc(#0,#1)" :one-liner t :side-effects nil)))
|
|
(when (member test '('EQUALP #'EQUALP) :test #'equal)
|
|
(return-from expand-assoc
|
|
`(ffi:c-inline (,value ,list) (:object :object) :object
|
|
"ecl_assqlp(#0,#1)" :one-liner t :side-effects nil)))))
|
|
(when test-function
|
|
(ext:with-unique-names (%value %sublist %elt %car)
|
|
`(let ((,%value ,value)
|
|
,@init)
|
|
(do-in-list (,%elt ,%sublist ,list)
|
|
(when ,%elt
|
|
(let ((,%car (cons-car (optional-type-check ,%elt cons))))
|
|
(when ,(funcall test-function %value
|
|
(funcall key-function %car))
|
|
(return ,%elt))))))))))
|
|
|
|
(define-compiler-macro assoc (&whole whole value list &rest sequence-args)
|
|
(if (policy-inline-sequence-functions)
|
|
(or (apply #'expand-assoc (rest whole))
|
|
whole)
|
|
whole))
|
|
|
|
;;;
|
|
;;; FIND
|
|
;;;
|
|
|
|
(defun expand-find (value sequence &rest sequence-args)
|
|
(multiple-value-bind (key-function test-function init
|
|
key-flag test-flag test start end)
|
|
(seq-opt-parse-args 'member sequence-args)
|
|
(when test-function
|
|
(ext:with-unique-names (%value %elt)
|
|
`(let ((,%value ,value)
|
|
,@init)
|
|
(do-in-seq (,%elt ,sequence)
|
|
(when ,(funcall test-function %value
|
|
(funcall key-function %elt))
|
|
(return ,%elt))))))))
|
|
|
|
(define-compiler-macro find (&whole whole value sequence &rest sequence-args)
|
|
(if (policy-inline-sequence-functions)
|
|
(or (apply #'expand-find (rest whole))
|
|
whole)
|
|
whole))
|