:documentation "Hash pred -> type.")
(union-typesets-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
-`comp-union-typesets'.")
+`comp--union-typesets'.")
;; TODO we should be able to just cons hash this.
(common-supertype-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`comp-cstr-ctxt-subtype-p-mem'.")
(union-1-mem-no-range (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
-`comp-cstr-union-1'.")
+`comp--cstr-union-1'.")
(union-1-mem-range (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
-`comp-cstr-union-1'.")
+`comp--cstr-union-1'.")
(intersection-mem (make-hash-table :test #'equal) :type hash-table
:documentation "Serve memoization for
`intersection-mem'."))
`(comp-cstr-neg ,x)))
,@body))
-(defun comp-cstr-copy (cstr)
+(defun comp--cstr-copy (cstr)
"Return a deep copy of CSTR."
(with-comp-cstr-accessors
(make-comp-cstr :typeset (copy-sequence (typeset cstr))
(null (neg cstr))
(equal (valset cstr) '(nil)))))
-(defun comp-cstrs-homogeneous (cstrs)
+(defun comp--cstrs-homogeneous (cstrs)
"Check if constraints CSTRS are all homogeneously negated or non-negated.
Return `pos' if they are all positive, `neg' if they are all
negated or nil otherwise."
((zerop n-neg) (cl-return 'pos))
((zerop n-pos) (cl-return 'neg)))))
-(defun comp-split-pos-neg (cstrs)
+(defun comp--split-pos-neg (cstrs)
"Split constraints CSTRS into non-negated and negated.
Return them as multiple value."
(cl-loop
\f
;;; Value handling.
-(defun comp-normalize-valset (valset)
+(defun comp--normalize-valset (valset)
"Sort and remove duplicates from VALSET then return it."
;; Sort valset as much as possible (by type and by value for symbols
;; and strings) to increase cache hits. But refrain to use
(cl-sort values #'string<)
values))))
-(defun comp-union-valsets (&rest valsets)
+(defun comp--union-valsets (&rest valsets)
"Union values present into VALSETS."
- (comp-normalize-valset (cl-reduce #'cl-union valsets)))
+ (comp--normalize-valset (cl-reduce #'cl-union valsets)))
-(defun comp-intersection-valsets (&rest valsets)
+(defun comp--intersection-valsets (&rest valsets)
"Union values present into VALSETS."
- (comp-normalize-valset (cl-reduce #'cl-intersection valsets)))
+ (comp--normalize-valset (cl-reduce #'cl-intersection valsets)))
\f
;;; Type handling.
(cl-return-from main 'restart)))))
typeset))
-(defun comp-normalize-typeset (typeset)
+(defun comp--normalize-typeset (typeset)
"Sort TYPESET and return it."
(cl-sort (comp--normalize-typeset0 (cl-remove-duplicates typeset)) #'comp--sym-lessp))
(or (assq type (comp-cstr-ctxt-typeof-types comp-ctxt))
(error "Type %S missing from typeof-types!" type)))
-(defun comp-union-typesets (&rest typesets)
+(defun comp--union-typesets (&rest typesets)
"Union types present into TYPESETS."
(or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
(puthash typesets
;; the other types.
unless (comp--intersection types res)
do (push (car types) res)
- finally return (comp-normalize-typeset res))
+ finally return (comp--normalize-typeset res))
(comp-cstr-ctxt-union-typesets-mem comp-ctxt))))
-(defun comp-intersect-two-typesets (t1 t2)
+(defun comp--intersect-two-typesets (t1 t2)
"Intersect typesets T1 and T2."
(with-comp-cstr-accessors
(cl-loop
other-types)
collect type))))
-(defun comp-intersect-typesets (&rest typesets)
+(defun comp--intersect-typesets (&rest typesets)
"Intersect types present into TYPESETS."
(unless (cl-some #'null typesets)
(if (length= typesets 1)
(car typesets)
- (comp-normalize-typeset
- (cl-reduce #'comp-intersect-two-typesets typesets)))))
+ (comp--normalize-typeset
+ (cl-reduce #'comp--intersect-two-typesets typesets)))))
\f
;;; Integer range handling
"Greater entry in RANGE."
(cdar (last range)))
-(defun comp-range-union (&rest ranges)
+(defun comp--range-union (&rest ranges)
"Combine integer intervals RANGES by union set operation."
(cl-loop
with all-ranges = (apply #'append ranges)
(cl-decf nest)
finally return (reverse res)))
-(defun comp-range-intersection (&rest ranges)
+(defun comp--range-intersection (&rest ranges)
"Combine integer intervals RANGES by intersecting."
(cl-loop
with all-ranges = (apply #'append ranges)
(cl-decf nest)
finally return (reverse res)))
-(defun comp-range-negation (range)
+(defun comp--range-negation (range)
"Negate range RANGE."
(if (null range)
'((- . +))
'(float))
(valset dst) ()
(range dst) (if (range old-dst)
- (comp-range-intersection (range old-dst)
+ (comp--range-intersection (range old-dst)
ext-range)
ext-range)
(neg dst) nil)
(comp-cstr-shallow-copy dst old-dst))))
(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body)
- ;; Prevent some code duplication for `comp-cstr-add-2'
- ;; `comp-cstr-sub-2'.
+ ;; Prevent some code duplication for `comp--cstr-add-2'
+ ;; `comp--cstr-sub-2'.
(declare (debug (range-body))
(indent defun))
`(with-comp-cstr-accessors
'(float))
(range ,dst) ,@range-body))))))
-(defun comp-cstr-add-2 (dst src1 src2)
+(defun comp--cstr-add-2 (dst src1 src2)
"Sum SRC1 and SRC2 into DST."
(comp-cstr-set-range-for-arithm dst src1 src2
`((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2)))))
-(defun comp-cstr-sub-2 (dst src1 src2)
+(defun comp--cstr-sub-2 (dst src1 src2)
"Subtract SRC1 and SRC2 into DST."
(comp-cstr-set-range-for-arithm dst src1 src2
(let ((l (comp-range-- l1 h2))
\f
;;; Union specific code.
-(defun comp-cstr-union-homogeneous-no-range (dst &rest srcs)
+(defun comp--cstr-union-homogeneous-no-range (dst &rest srcs)
"As `comp-cstr-union' but excluding the irange component.
All SRCS constraints must be homogeneously negated or non-negated."
;; Type propagation.
(setf (comp-cstr-typeset dst)
- (apply #'comp-union-typesets (mapcar #'comp-cstr-typeset srcs)))
+ (apply #'comp--union-typesets (mapcar #'comp-cstr-typeset srcs)))
;; Value propagation.
(setf (comp-cstr-valset dst)
- (comp-normalize-valset
+ (comp--normalize-valset
(cl-loop
with values = (mapcar #'comp-cstr-valset srcs)
;; TODO sort.
dst)
-(defun comp-cstr-union-homogeneous (range dst &rest srcs)
+(defun comp--cstr-union-homogeneous (range dst &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
Do range propagation when RANGE is non-nil.
All SRCS constraints must be homogeneously negated or non-negated.
DST is returned."
- (apply #'comp-cstr-union-homogeneous-no-range dst srcs)
+ (apply #'comp--cstr-union-homogeneous-no-range dst srcs)
;; Range propagation.
(setf (comp-cstr-neg dst)
(when srcs
(comp-subtype-p 'integer x))
(comp-cstr-typeset dst))
(if range
- (apply #'comp-range-union
+ (apply #'comp--range-union
(mapcar #'comp-cstr-range srcs))
'((- . +)))))
dst)
-(cl-defun comp-cstr-union-1-no-mem (range &rest srcs)
+(cl-defun comp--cstr-union-1-no-mem (range &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
Do range propagation when RANGE is non-nil.
-Non memoized version of `comp-cstr-union-1'.
+Non memoized version of `comp--cstr-union-1'.
DST is returned."
(with-comp-cstr-accessors
(let ((dst (make-comp-cstr)))
(valset dst) ()
(range dst) ()
(neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst)))
+ (cl-return-from comp--cstr-union-1-no-mem dst)))
;; Check first if we are in the simple case of all input non-negate
;; or negated so we don't have to cons.
- (when-let ((res (comp-cstrs-homogeneous srcs)))
- (apply #'comp-cstr-union-homogeneous range dst srcs)
- (cl-return-from comp-cstr-union-1-no-mem dst))
+ (when-let ((res (comp--cstrs-homogeneous srcs)))
+ (apply #'comp--cstr-union-homogeneous range dst srcs)
+ (cl-return-from comp--cstr-union-1-no-mem dst))
;; Some are negated and some are not
- (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
- (let* ((pos (apply #'comp-cstr-union-homogeneous range
+ (cl-multiple-value-bind (positives negatives) (comp--split-pos-neg srcs)
+ (let* ((pos (apply #'comp--cstr-union-homogeneous range
(make-comp-cstr) positives))
;; We'll always use neg as result as this is almost
;; always necessary for describing open intervals
;; resulting from negated constraints.
- (neg (apply #'comp-cstr-union-homogeneous range
+ (neg (apply #'comp--cstr-union-homogeneous range
(make-comp-cstr :neg t) negatives)))
;; Type propagation.
(when (and (typeset pos)
(typeset neg)))
(comp-cstr-shallow-copy dst pos)
(setf (neg dst) nil)
- (cl-return-from comp-cstr-union-1-no-mem dst))
+ (cl-return-from comp--cstr-union-1-no-mem dst))
;; Verify disjoint condition between positive types and
;; negative types coming from values, in case give-up.
;; Value propagation.
(cond
((and (valset pos) (valset neg)
- (equal (comp-union-valsets (valset pos) (valset neg))
+ (equal (comp--union-valsets (valset pos) (valset neg))
(valset pos)))
;; Pos is a superset of neg.
(give-up))
(equal (range pos) (range neg)))
(give-up)
(setf (range neg)
- (comp-range-negation
- (comp-range-union
- (comp-range-negation (range neg))
+ (comp--range-negation
+ (comp--range-union
+ (comp--range-negation (range neg))
(range pos))))))
(comp-cstr-shallow-copy dst (if (comp-cstr-empty-p neg)
dst)))
-(defun comp-cstr-union-1 (range dst &rest srcs)
+(defun comp--cstr-union-1 (range dst &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
Do range propagation when RANGE is non-nil.
DST is returned."
(comp-cstr-ctxt-union-1-mem-no-range comp-ctxt)))
(res (or (gethash srcs mem-h)
(puthash
- (mapcar #'comp-cstr-copy srcs)
- (apply #'comp-cstr-union-1-no-mem range srcs)
+ (mapcar #'comp--cstr-copy srcs)
+ (apply #'comp--cstr-union-1-no-mem range srcs)
mem-h))))
(comp-cstr-shallow-copy dst res)
res)))
;; Type propagation.
(setf (typeset dst)
- (apply #'comp-intersect-typesets
+ (apply #'comp--intersect-typesets
(mapcar #'comp-cstr-typeset srcs)))
;; Value propagation.
(setf (valset dst)
- (comp-normalize-valset
+ (comp--normalize-valset
(cl-loop
for src in srcs
append
(unless (cl-some (lambda (type)
(comp-subtype-p 'integer type))
(typeset dst))
- (apply #'comp-range-intersection
+ (apply #'comp--range-intersection
(cl-loop
for src in srcs
;; Collect effective ranges.
(range dst) ()
(neg dst) nil)
(cl-return-from comp-cstr-intersection-no-mem dst)))
- (when-let ((res (comp-cstrs-homogeneous srcs)))
+ (when-let ((res (comp--cstrs-homogeneous srcs)))
(if (eq res 'neg)
- (apply #'comp-cstr-union-homogeneous t dst srcs)
+ (apply #'comp--cstr-union-homogeneous t dst srcs)
(apply #'comp-cstr-intersection-homogeneous dst srcs))
(cl-return-from comp-cstr-intersection-no-mem dst))
;; Some are negated and some are not
- (cl-multiple-value-bind (positives negatives) (comp-split-pos-neg srcs)
+ (cl-multiple-value-bind (positives negatives) (comp--split-pos-neg srcs)
(let* ((pos (apply #'comp-cstr-intersection-homogeneous
(make-comp-cstr) positives))
(neg (apply #'comp-cstr-intersection-homogeneous
do (setf found t))))
(setf (range pos)
- (comp-range-intersection (range pos)
- (comp-range-negation (range neg)))
+ (comp--range-intersection (range pos)
+ (comp--range-negation (range neg)))
(valset pos)
(cl-set-difference (valset pos) (valset neg)))
(defun comp-cstr-add (dst srcs)
"Sum SRCS into DST."
- (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs))
+ (comp--cstr-add-2 dst (cl-first srcs) (cl-second srcs))
(cl-loop
for src in (nthcdr 2 srcs)
- do (comp-cstr-add-2 dst dst src)))
+ do (comp--cstr-add-2 dst dst src)))
(defun comp-cstr-sub (dst srcs)
"Subtract SRCS into DST."
- (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs))
+ (comp--cstr-sub-2 dst (cl-first srcs) (cl-second srcs))
(cl-loop
for src in (nthcdr 2 srcs)
- do (comp-cstr-sub-2 dst dst src)))
+ do (comp--cstr-sub-2 dst dst src)))
(defun comp-cstr-union-no-range (dst &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
Do not propagate the range component.
DST is returned."
- (apply #'comp-cstr-union-1 nil dst srcs))
+ (apply #'comp--cstr-union-1 nil dst srcs))
(defun comp-cstr-union (dst &rest srcs)
"Combine SRCS by union set operation setting the result in DST.
DST is returned."
- (apply #'comp-cstr-union-1 t dst srcs))
+ (apply #'comp--cstr-union-1 t dst srcs))
-(defun comp-cstr-union-make (&rest srcs)
+(defun comp--cstr-union-make (&rest srcs)
"Combine SRCS by union set operation and return a new constraint."
(apply #'comp-cstr-union (make-comp-cstr) srcs))
(let* ((mem-h (comp-cstr-ctxt-intersection-mem comp-ctxt))
(res (or (gethash srcs mem-h)
(puthash
- (mapcar #'comp-cstr-copy srcs)
+ (mapcar #'comp--cstr-copy srcs)
(apply #'comp-cstr-intersection-no-mem srcs)
mem-h))))
(comp-cstr-shallow-copy dst res)
do (push v strip-values)
(push (cl-type-of v) strip-types))
(when strip-values
- (setf (typeset dst) (comp-union-typesets (typeset dst) strip-types)
+ (setf (typeset dst) (comp--union-typesets (typeset dst) strip-types)
(valset dst) (cl-set-difference (valset dst) strip-values)))
(cl-loop for (l . h) in (range dst)
when (or (bignump l) (bignump h))
(cl-return))))
dst))
-(defun comp-cstr-intersection-make (&rest srcs)
+(defun comp--cstr-intersection-make (&rest srcs)
"Combine SRCS by intersection set operation and return a new constraint."
(apply #'comp-cstr-intersection (make-comp-cstr) srcs))
((pred atom)
(comp--type-to-cstr type-spec))
(`(or . ,rest)
- (apply #'comp-cstr-union-make
+ (apply #'comp--cstr-union-make
(mapcar #'comp-type-spec-to-cstr rest)))
(`(and . ,rest)
- (apply #'comp-cstr-intersection-make
+ (apply #'comp--cstr-intersection-make
(mapcar #'comp-type-spec-to-cstr rest)))
(`(not ,cstr)
(comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
;; No float range support :/
(comp--type-to-cstr 'float))
(`(member . ,rest)
- (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest)))
+ (apply #'comp--cstr-union-make (mapcar #'comp--value-to-cstr rest)))
(`(function ,args ,ret)
(make-comp-cstr-f
:args (mapcar (lambda (x)
(declare-function comp-el-to-eln-filename "comp.c")
(declare-function native-elisp-load "comp.c")
-(defun native-compile-async-skip-p (file load selector)
+(defun native--compile-async-skip-p (file load selector)
"Return non-nil if FILE's compilation should be skipped.
LOAD and SELECTOR work as described in `native--compile-async'."
(defvar comp-async-compilations (make-hash-table :test #'equal)
"Hash table file-name -> async compilation process.")
-(defun comp-async-runnings ()
+(defun comp--async-runnings ()
"Return the number of async compilations currently running.
This function has the side effect of cleaning-up finished
processes from `comp-async-compilations'"
(hash-table-count comp-async-compilations))
(defvar comp-num-cpus nil)
-(defun comp-effective-async-max-jobs ()
+(defun comp--effective-async-max-jobs ()
"Compute the effective number of async jobs."
(if (zerop native-comp-async-jobs-number)
(or comp-num-cpus
(make-variable-buffer-local 'comp-last-scanned-async-output)
;; From warnings.el
(defvar warning-suppress-types)
-(defun comp-accept-and-process-async-output (process)
+(defun comp--accept-and-process-async-output (process)
"Accept PROCESS output and check for diagnostic messages."
(if native-comp-async-report-warnings-errors
(let ((warning-suppress-types
(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
"Regexp to match filename of valid input source files.")
-(defun comp-run-async-workers ()
+(defun comp--run-async-workers ()
"Start compiling files from `comp-files-queue' asynchronously.
When compilation is finished, run `native-comp-async-all-done-hook' and
display a message."
(cl-assert (null comp-no-spawn))
(if (or comp-files-queue
- (> (comp-async-runnings) 0))
- (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ (> (comp--async-runnings) 0))
+ (unless (>= (comp--async-runnings) (comp--effective-async-max-jobs))
(cl-loop
for (source-file . load) = (pop comp-files-queue)
while source-file
(run-hook-with-args
'native-comp-async-cu-done-functions
source-file)
- (comp-accept-and-process-async-output process)
+ (comp--accept-and-process-async-output process)
(ignore-errors (delete-file temp-file))
(let ((eln-file (comp-el-to-eln-filename
source-file1)))
(file-exists-p eln-file))
(native-elisp-load eln-file
(eq load1 'late))))
- (comp-run-async-workers))
+ (comp--run-async-workers))
:noquery (not native-comp-async-query-on-exit))))
(puthash source-file process comp-async-compilations))
- when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ when (>= (comp--async-runnings) (comp--effective-async-max-jobs))
do (cl-return)))
;; No files left to compile and all processes finished.
(run-hooks 'native-comp-async-all-done-hook)
"List of primitives we want to warn about in case of redefinition.
This are essential for the trampoline machinery to work properly.")
-(defun comp-trampoline-search (subr-name)
+(defun comp--trampoline-search (subr-name)
"Search a trampoline file for SUBR-NAME.
Return the trampoline if found or nil otherwise."
(cl-loop
(memq subr-name native-comp-never-optimize-functions)
(gethash subr-name comp-installed-trampolines-h))
(cl-assert (subr-primitive-p subr))
- (when-let ((trampoline (or (comp-trampoline-search subr-name)
+ (when-let ((trampoline (or (comp--trampoline-search subr-name)
(comp-trampoline-compile subr-name))))
(comp--install-trampoline subr-name trampoline)))))
else
collect i)))
- (unless (native-compile-async-skip-p file load selector)
+ (unless (native--compile-async-skip-p file load selector)
(let* ((out-filename (comp-el-to-eln-filename file))
(out-dir (file-name-directory out-filename)))
(unless (file-exists-p out-dir)
(display-warning 'comp
(format "No write access for %s skipping."
out-filename)))))))
- ;; Perhaps nothing passed `native-compile-async-skip-p'?
+ ;; Perhaps nothing passed `native--compile-async-skip-p'?
(when (and added-something
;; Don't start if there's one already running.
- (zerop (comp-async-runnings)))
- (comp-run-async-workers))))
+ (zerop (comp--async-runnings)))
+ (comp--run-async-workers))))
;;;###autoload
(defun native-compile-async (files &optional recursively load selector)
projects / emacs.git / commitdiff