+
+(define-hash-table-test 'profiler-function-equal #'function-equal
+ (lambda (f) (cond
+ ((byte-code-function-p f) (aref f 1))
+ ((eq (car-safe f) 'closure) (cddr f))
+ (t f))))
+
+(defun profiler-calltree-build-unified (tree log)
+ ;; Let's try to unify all those partial backtraces into a single
+ ;; call tree. First, we record in fun-map all the functions that appear
+ ;; in `log' and where they appear.
+ (let ((fun-map (make-hash-table :test 'profiler-function-equal))
+ (parent-map (make-hash-table :test 'eq))
+ (leftover-tree (profiler-make-calltree
+ :entry (intern "...") :parent tree)))
+ (push leftover-tree (profiler-calltree-children tree))
+ (maphash
+ (lambda (backtrace _count)
+ (let ((max (length backtrace)))
+ ;; Don't record the head elements in there, since we want to use this
+ ;; fun-map to find parents of partial backtraces, but parents only
+ ;; make sense if they have something "above".
+ (dotimes (i (1- max))
+ (let ((f (aref backtrace i)))
+ (when f
+ (push (cons i backtrace) (gethash f fun-map)))))))
+ log)
+ ;; Then, for each partial backtrace, try to find a parent backtrace
+ ;; (i.e. a backtrace that describes (part of) the truncated part of
+ ;; the partial backtrace). For a partial backtrace like "[f3 f2 f1]" (f3
+ ;; is deeper), any backtrace that includes f1 could be a parent; and indeed
+ ;; the counts of this partial backtrace could each come from a different
+ ;; parent backtrace (some of which may not even be in `log'). So we should
+ ;; consider each backtrace that includes f1 and give it some percentage of
+ ;; `count'. But we can't know for sure what percentage to give to each
+ ;; possible parent.
+ ;; The "right" way might be to give a percentage proportional to the counts
+ ;; already registered for that parent, or some such statistical principle.
+ ;; But instead, we will give all our counts to a single "best
+ ;; matching" parent. So let's look for the best matching parent, and store
+ ;; the result in parent-map.
+ ;; Using the "best matching parent" is important also to try and avoid
+ ;; stitching together backtraces that can't possibly go together.
+ ;; For example, when the head is `apply' (or `mapcar', ...), we want to
+ ;; make sure we don't just use any parent that calls `apply', since most of
+ ;; them would never, in turn, cause apply to call the subsequent function.
+ (maphash
+ (lambda (backtrace _count)
+ (let* ((max (1- (length backtrace)))
+ (head (aref backtrace max))
+ (best-parent nil)
+ (best-match (1+ max))
+ (parents (gethash head fun-map)))
+ (pcase-dolist (`(,i . ,parent) parents)
+ (when t ;; (<= (- max i) best-match) ;Else, it can't be better.
+ (let ((match max)
+ (imatch i))
+ (cl-assert (>= match imatch))
+ (cl-assert (function-equal (aref backtrace max)
+ (aref parent i)))
+ (while (progn
+ (cl-decf imatch) (cl-decf match)
+ (when (> imatch 0)
+ (function-equal (aref backtrace match)
+ (aref parent imatch)))))
+ (when (< match best-match)
+ (cl-assert (<= (- max i) best-match))
+ ;; Let's make sure this parent is not already our child: we
+ ;; don't want cycles here!
+ (let ((valid t)
+ (tmp-parent parent))
+ (while (setq tmp-parent
+ (if (eq tmp-parent backtrace)
+ (setq valid nil)
+ (cdr (gethash tmp-parent parent-map)))))
+ (when valid
+ (setq best-match match)
+ (setq best-parent (cons i parent))))))))
+ (puthash backtrace best-parent parent-map)))
+ log)
+ ;; Now we have a single parent per backtrace, so we have a unified tree.
+ ;; Let's build the actual call-tree from it.
+ (maphash
+ (lambda (backtrace count)
+ (let ((node tree)
+ (parents (list (cons -1 backtrace)))
+ (tmp backtrace)
+ (max (length backtrace)))
+ (while (setq tmp (gethash tmp parent-map))
+ (push tmp parents)
+ (setq tmp (cdr tmp)))
+ (when (aref (cdar parents) (1- max))
+ (cl-incf (profiler-calltree-count leftover-tree) count)
+ (setq node leftover-tree))
+ (pcase-dolist (`(,i . ,parent) parents)
+ (let ((j (1- max)))
+ (while (> j i)
+ (let ((f (aref parent j)))
+ (cl-decf j)
+ (when f
+ (let ((child (profiler-calltree-find node f)))
+ (unless child
+ (setq child (profiler-make-calltree
+ :entry f :parent node))
+ (push child (profiler-calltree-children node)))
+ (cl-incf (profiler-calltree-count child) count)
+ (setq node child)))))))))
+ log)))
+