From 58469d54ff9146084f1951e47d310c639912a3b8 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 12:27:49 +0100 Subject: [PATCH 01/16] wip --- deps.edn | 3 +- src/nextjournal/clerk/analyzer.clj | 4 +- src/nextjournal/clerk/clojure/core/cache.clj | 658 ++++++++++++++++++ .../clerk/clojure/core/memoize.clj | 509 ++++++++++++++ .../clerk/clojure/data/priority_map.clj | 510 ++++++++++++++ .../clerk/clojure/tools/analyzer/jvm.clj | 628 +++++++++++++++++ .../clojure/tools/analyzer/jvm/utils.clj | 399 +++++++++++ .../analyzer/passes/jvm/analyze_host_expr.clj | 198 ++++++ .../analyzer/passes/jvm/annotate_branch.clj | 46 ++ .../passes/jvm/annotate_host_info.clj | 109 +++ .../analyzer/passes/jvm/annotate_loops.clj | 132 ++++ .../analyzer/passes/jvm/annotate_tag.clj | 96 +++ .../clojure/tools/analyzer/passes/jvm/box.clj | 200 ++++++ .../analyzer/passes/jvm/classify_invoke.clj | 91 +++ .../analyzer/passes/jvm/constant_lifter.clj | 26 + .../tools/analyzer/passes/jvm/emit_form.clj | 169 +++++ .../analyzer/passes/jvm/fix_case_test.clj | 19 + .../tools/analyzer/passes/jvm/infer_tag.clj | 280 ++++++++ .../tools/analyzer/passes/jvm/validate.clj | 274 ++++++++ .../passes/jvm/validate_loop_locals.clj | 152 ++++ .../analyzer/passes/jvm/validate_recur.clj | 40 ++ .../passes/jvm/warn_on_reflection.clj | 62 ++ 22 files changed, 4602 insertions(+), 3 deletions(-) create mode 100644 src/nextjournal/clerk/clojure/core/cache.clj create mode 100644 src/nextjournal/clerk/clojure/core/memoize.clj create mode 100644 src/nextjournal/clerk/clojure/data/priority_map.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj create mode 100644 src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj diff --git a/deps.edn b/deps.edn index 9a2f68ceb..ed460da89 100644 --- a/deps.edn +++ b/deps.edn @@ -2,7 +2,8 @@ :deps {org.clojure/clojure {:mvn/version "1.10.3"} org.clojure/java.classpath {:mvn/version "1.0.0"} org.clojure/tools.analyzer {:mvn/version "1.2.0"} - org.clojure/tools.analyzer.jvm {:mvn/version "1.3.0"} + ;; org.clojure/tools.analyzer.jvm {:mvn/version "1.3.0"} + org.ow2.asm/asm {:mvn/version "9.2"} ;; tools.analyzer dependency babashka/fs {:mvn/version "0.5.22"} borkdude/edamame {:mvn/version "1.4.24"} weavejester/dependency {:mvn/version "0.2.1"} diff --git a/src/nextjournal/clerk/analyzer.clj b/src/nextjournal/clerk/analyzer.clj index b8874be4c..694d49d80 100644 --- a/src/nextjournal/clerk/analyzer.clj +++ b/src/nextjournal/clerk/analyzer.clj @@ -8,13 +8,13 @@ [clojure.string :as str] [clojure.tools.analyzer :as ana] [clojure.tools.analyzer.ast :as ana-ast] - [clojure.tools.analyzer.jvm :as ana-jvm] [clojure.tools.analyzer.utils :as ana-utils] [multiformats.base.b58 :as b58] [multiformats.hash :as hash] - [nextjournal.clerk.parser :as parser] [nextjournal.clerk.classpath :as cp] + [nextjournal.clerk.clojure.tools.analyzer.jvm :as ana-jvm] [nextjournal.clerk.config :as config] + [nextjournal.clerk.parser :as parser] [nextjournal.clerk.walk :as walk] [taoensso.nippy :as nippy] [weavejester.dependency :as dep])) diff --git a/src/nextjournal/clerk/clojure/core/cache.clj b/src/nextjournal/clerk/clojure/core/cache.clj new file mode 100644 index 000000000..07585c87d --- /dev/null +++ b/src/nextjournal/clerk/clojure/core/cache.clj @@ -0,0 +1,658 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(ns ^{:doc "A caching library for Clojure." + :author "Fogus"} + nextjournal.clerk.clojure.core.cache + (:require [nextjournal.clerk.clojure.data.priority-map :as clojure.data.priority-map]) + (:import (java.lang.ref ReferenceQueue SoftReference) + (java.util.concurrent ConcurrentHashMap))) + +(set! *warn-on-reflection* true) + +;; # Protocols and Types + +(defprotocol CacheProtocol + "This is the protocol describing the basic cache capability." + (lookup [cache e] + [cache e not-found] + "Retrieve the value associated with `e` if it exists, else `nil` in + the 2-arg case. Retrieve the value associated with `e` if it exists, + else `not-found` in the 3-arg case.") + (has? [cache e] + "Checks if the cache contains a value associated with `e`") + (hit [cache e] + "Is meant to be called if the cache is determined to contain a value + associated with `e`") + (miss [cache e ret] + "Is meant to be called if the cache is determined to **not** contain a + value associated with `e`") + (evict [cache e] + "Removes an entry from the cache") + (seed [cache base] + "Is used to signal that the cache should be created with a seed. + The contract is that said cache should return an instance of its + own type.")) + +(def ^{:private true} default-wrapper-fn #(%1 %2)) + +(defn through + "The basic hit/miss logic for the cache system. Expects a wrap function and + value function. The wrap function takes the value function and the item in question + and is expected to run the value function with the item whenever a cache + miss occurs. The intent is to hide any cache-specific cells from leaking + into the cache logic itelf." + ([cache item] (through default-wrapper-fn identity cache item)) + ([value-fn cache item] (through default-wrapper-fn value-fn cache item)) + ([wrap-fn value-fn cache item] + (if (nextjournal.clerk.clojure.core.cache/has? cache item) + (nextjournal.clerk.clojure.core.cache/hit cache item) + (nextjournal.clerk.clojure.core.cache/miss cache item (wrap-fn #(value-fn %) item))))) + +(defn through-cache + "The basic hit/miss logic for the cache system. Like through but always has + the cache argument in the first position for easier use with swap! etc." + ([cache item] (through-cache cache item default-wrapper-fn identity)) + ([cache item value-fn] (through-cache cache item default-wrapper-fn value-fn)) + ([cache item wrap-fn value-fn] + (if (nextjournal.clerk.clojure.core.cache/has? cache item) + (nextjournal.clerk.clojure.core.cache/hit cache item) + (nextjournal.clerk.clojure.core.cache/miss cache item (wrap-fn #(value-fn %) item))))) + +(defmacro defcache + [type-name fields & specifics] + (let [[base & _] fields + base-field (with-meta base {:tag 'clojure.lang.IPersistentMap})] + `(deftype ~type-name [~@fields] + ~@specifics + + clojure.lang.ILookup + (valAt [this# key#] + (lookup this# key#)) + (valAt [this# key# not-found#] + (if (has? this# key#) + (lookup this# key#) + not-found#)) + + java.lang.Iterable + (iterator [_#] + (.iterator ~base-field)) + + clojure.lang.IPersistentMap + (assoc [this# k# v#] + (miss this# k# v#)) + (without [this# k#] + (evict this# k#)) + + clojure.lang.Associative + (containsKey [this# k#] + (has? this# k#)) + (entryAt [this# k#] + (when (has? this# k#) + (clojure.lang.MapEntry. k# (lookup this# k#)))) + + clojure.lang.Counted + (count [this#] + (count ~base-field)) + + clojure.lang.IPersistentCollection + (cons [this# elem#] + (seed this# (conj ~base-field elem#))) + (empty [this#] + (seed this# (empty ~base-field))) + (equiv [this# other#] + (= other# ~base-field)) + + clojure.lang.Seqable + (seq [_#] + (seq ~base-field))))) + +(defcache BasicCache [cache] + CacheProtocol + (lookup [_ item] + (get cache item)) + (lookup [_ item not-found] + (get cache item not-found)) + (has? [_ item] + (contains? cache item)) + (hit [this item] this) + (miss [_ item result] + (BasicCache. (assoc cache item result))) + (evict [_ key] + (BasicCache. (dissoc cache key))) + (seed [_ base] + (BasicCache. base)) + Object + (toString [_] (str cache))) + +;; FnCache + +(defcache FnCache [cache f] + CacheProtocol + (lookup [_ item] + (f (get cache item))) + (lookup [_ item not-found] + (let [ret (get cache item not-found)] + (if (= not-found ret) + not-found + (f ret)))) + (has? [_ item] + (contains? cache item)) + (hit [this item] this) + (miss [_ item result] + (BasicCache. (assoc cache item result))) + (evict [_ key] + (BasicCache. (dissoc cache key))) + (seed [_ base] + (BasicCache. base)) + Object + (toString [_] (str cache))) + +;; # FIFO + +(defn- describe-layout [mappy limit] + (let [ks (keys mappy) + [dropping keeping] (split-at (- (count ks) limit) ks)] + {:dropping dropping + :keeping keeping + :queue + (-> clojure.lang.PersistentQueue/EMPTY + (into (repeat (- limit (count keeping)) ::free)) + (into (take limit keeping)))})) + +(defn- prune-queue [q k] + (reduce (fn [q e] (if (#{k} e) q (conj q e))) + (conj clojure.lang.PersistentQueue/EMPTY ::free) + q)) + +(defcache FIFOCache [cache q limit] + CacheProtocol + (lookup [_ item] + (get cache item)) + (lookup [_ item not-found] + (get cache item not-found)) + (has? [_ item] + (contains? cache item)) + (hit [this item] + this) + (miss [_ item result] + (let [[kache qq] (let [k (peek q)] + (if (>= (count cache) limit) + [(dissoc cache k) (pop q)] + [cache (pop q)]))] + (FIFOCache. (assoc kache item result) + (conj qq item) + limit))) + (evict [this key] + (if (contains? cache key) + (FIFOCache. (dissoc cache key) + (prune-queue q key) + limit) + this)) + (seed [_ base] + (let [{dropping :dropping + q :queue} (describe-layout base limit)] + (FIFOCache. (apply dissoc base dropping) + q + limit))) + Object + (toString [_] + (str cache \, \space (pr-str q)))) + +(defn- build-leastness-queue + [base start-at] + (into (clojure.data.priority-map/priority-map) (for [[k _] base] [k start-at]))) + +(defcache LRUCache [cache lru tick limit] + CacheProtocol + (lookup [_ item] + (get cache item)) + (lookup [_ item not-found] + (get cache item not-found)) + (has? [_ item] + (contains? cache item)) + (hit [_ item] + (let [tick+ (inc tick)] + (LRUCache. cache + (if (contains? cache item) + (assoc lru item tick+) + lru) + tick+ + limit))) + (miss [_ item result] + (let [tick+ (inc tick)] + (if (>= (count lru) limit) + (let [k (if (contains? lru item) + item + (first (peek lru))) ;; minimum-key, maybe evict case + c (-> cache (dissoc k) (assoc item result)) + l (-> lru (dissoc k) (assoc item tick+))] + (LRUCache. c l tick+ limit)) + (LRUCache. (assoc cache item result) ;; no change case + (assoc lru item tick+) + tick+ + limit)))) + (evict [this key] + (if (contains? cache key) + (LRUCache. (dissoc cache key) + (dissoc lru key) + (inc tick) + limit) + this)) + (seed [_ base] + (LRUCache. base + (build-leastness-queue base 0) + 0 + limit)) + Object + (toString [_] + (str cache \, \space lru \, \space tick \, \space limit))) + + +(defn- key-killer-q + [ttl q expiry now] + (let [[ks q'] (reduce (fn [[ks q] [k g t]] + (if (> (- now t) expiry) + (if (= g (first (get ttl k))) + [(conj ks k) (pop q)] + [ks (pop q)]) + (reduced [ks q]))) + [[] q] + q)] + [#(apply dissoc % ks) q'])) + +(defcache TTLCacheQ [cache ttl q gen ttl-ms] + CacheProtocol + (lookup [this item] + (let [ret (lookup this item ::nope)] + (when-not (= ::nope ret) ret))) + (lookup [this item not-found] + (if (has? this item) + (get cache item) + not-found)) + (has? [_ item] + (and (let [[_ t] (get ttl item [0 (- ttl-ms)])] + (< (- (System/currentTimeMillis) + t) + ttl-ms)) + (contains? cache item))) + (hit [this item] this) + (miss [this item result] + (let [now (System/currentTimeMillis) + [kill-old q'] (key-killer-q ttl q ttl-ms now)] + (TTLCacheQ. (assoc (kill-old cache) item result) + (assoc (kill-old ttl) item [gen now]) + (conj q' [item gen now]) + (unchecked-inc gen) + ttl-ms))) + (seed [_ base] + (let [now (System/currentTimeMillis)] + (TTLCacheQ. base + ;; we seed the cache all at gen, but subsequent entries + ;; will get gen+1, gen+2 etc + (into {} (for [x base] [(key x) [gen now]])) + (into q (for [x base] [(key x) gen now])) + (unchecked-inc gen) + ttl-ms))) + (evict [_ key] + (TTLCacheQ. (dissoc cache key) + (dissoc ttl key) + q + gen + ttl-ms)) + Object + (toString [_] + (str cache \, \space ttl \, \space ttl-ms))) + + +(defcache LUCache [cache lu limit] + CacheProtocol + (lookup [_ item] + (get cache item)) + (lookup [_ item not-found] + (get cache item not-found)) + (has? [_ item] + (contains? cache item)) + (hit [_ item] + (LUCache. cache (update-in lu [item] inc) limit)) + (miss [_ item result] + (if (>= (count lu) limit) ;; need to evict? + (let [min-key (if (contains? lu item) + ::nope + (first (peek lu))) ;; maybe evict case + c (-> cache (dissoc min-key) (assoc item result)) + l (-> lu (dissoc min-key) (update-in [item] (fnil inc 0)))] + (LUCache. c l limit)) + (LUCache. (assoc cache item result) ;; no change case + (update-in lu [item] (fnil inc 0)) + limit))) + (evict [this key] + (if (contains? this key) + (LUCache. (dissoc cache key) + (dissoc lu key) + limit) + this)) + (seed [_ base] + (LUCache. base + (build-leastness-queue base 0) + limit)) + Object + (toString [_] + (str cache \, \space lu \, \space limit))) + + +;; # LIRS +;; *initial Clojure implementation by Jan Oberhagemann* + +;; A +;; [LIRS](http://citeseer.ist.psu.edu/viewdoc/summary?doi=10.1.1.116.2184) +;; cache consists of two LRU lists, `S` and `Q`, and keeps more history +;; than a LRU cache. Every cached item is either a LIR, HIR or +;; non-resident HIR block. `Q` contains only HIR blocks, `S` contains +;; LIR, HIR, non-resident HIR blocks. The total cache size is +;; |`S`|+|`Q`|, |`S`| is typically 99% of the cache size. + +;; * LIR block: +;; Low Inter-Reference block, a cached item with a short interval +;; between accesses. A block `x`, `x` ∈ `S` ∧ `x` ∉ `Q` ∧ `x` ∈ +;; `cache`, is a LIR block. + +;; * HIR block: +;; High Inter-Reference block, a cached item with rare accesses and +;; long interval. A block `x`, `x` ∈ `Q` ∧ `x` ∈ `cache`, is a HIR block. + +;; * non-resident HIR block: +;; only the key of the HIR block is cached, without the corresponding +;; value a test (has?) for the corresponding key is always a +;; miss. Used for additional history information. A block `x`, `x` ∈ +;; `S` ∧ `x` ∉ `Q` ∧ `x` ∉ `cache`, is a non-resident HIR block. + +;; ## Outline of the implemented algorithm + +;; `cache` is used to store the key value pairs. +;; `S` and `Q` maintain the relative order of accesses of the keys, like +;; a LRU list. + +;; Definition of `prune stack`: +;; +;; repeatedly remove oldest item from S until an item k, k ∉ Q ∧ +;; k ∈ cache (a LIR block), is found + + +;; In case of a miss for key `k` and value `v` (`k` ∉ cache) and +;; +;; * (1.1) `S` is not filled, |`S`| < `limitS` +;; add k to S +;; add k to the cache + +;; * (1.2) `k` ∉ `S`, never seen or not seen for a long, long time +;; remove oldest item x from Q +;; remove x from cache +;; add k to S +;; add k to Q +;; add k to the cache + +;; * (1.3) `k` ∈ `S`, this is a non-resident HIR block +;; remove oldest item x from Q +;; remove x from cache +;; add k to S +;; remove oldest item y from S +;; add y to Q +;; prune stack + + +;; In case of a hit for key `k` (`k` ∈ cache) and + +;; * (2.1) `k` ∈ `S` ∧ `k` ∉ `Q`, a LIR block +;; add k to S / refresh +;; prune stack if k was the oldest item in S + +;; * (2.2) `k` ∈ `S` ∧ `k` ∈ `Q`, a HIR block +;; add k to S / refresh +;; remove k from Q +;; remove oldest item x from S +;; add x to Q +;; prune stack + +;; * (2.3) `k` ∉ `S` ∧ `k` ∈ `Q`, a HIR block, only older than the oldest item in S +;; add k to S +;; add k to Q / refresh + +(defn- prune-stack [lruS lruQ cache] + (loop [s lruS q lruQ c cache] + (let [k (apply min-key s (keys s))] + (if (or (contains? q k) ; HIR item + (not (contains? c k))) ; non-resident HIR item + (recur (dissoc s k) q c) + s)))) + +(defcache LIRSCache [cache lruS lruQ tick limitS limitQ] + CacheProtocol + (lookup [_ item] + (get cache item)) + (lookup [_ item not-found] + (get cache item not-found)) + (has? [_ item] + (contains? cache item)) + (hit [_ item] + (let [tick+ (inc tick)] + (if (not (contains? lruS item)) + ; (2.3) item ∉ S ∧ item ∈ Q + (LIRSCache. cache (assoc lruS item tick+) (assoc lruQ item tick+) tick+ limitS limitQ) + (let [k (apply min-key lruS (keys lruS))] + (if (contains? lruQ item) + ; (2.2) item ∈ S ∧ item ∈ Q + (let [new-lruQ (-> lruQ (dissoc item) (assoc k tick+))] + (LIRSCache. cache + (-> lruS (dissoc k) (assoc item tick+) (prune-stack new-lruQ cache)) + new-lruQ + tick+ + limitS + limitQ)) + ; (2.1) item ∈ S ∧ item ∉ Q + (LIRSCache. cache + (-> lruS (assoc item tick+) (prune-stack lruQ cache)) + lruQ + tick+ + limitS + limitQ)))))) + + (miss [_ item result] + (let [tick+ (inc tick)] + (if (< (count cache) limitS) + ; (1.1) + (let [k (apply min-key lruS (keys lruS))] + (LIRSCache. (assoc cache item result) + (-> lruS (dissoc k) (assoc item tick+)) + lruQ + tick+ + limitS + limitQ)) + (let [k (apply min-key lruQ (keys lruQ)) + new-lruQ (dissoc lruQ k) + new-cache (-> cache (dissoc k) (assoc item result))] + (if (contains? lruS item) + ; (1.3) + (let [lastS (apply min-key lruS (keys lruS))] + (LIRSCache. new-cache + (-> lruS (dissoc lastS) (assoc item tick+) (prune-stack new-lruQ new-cache)) + (assoc new-lruQ lastS tick+) + tick+ + limitS + limitQ)) + ; (1.2) + (LIRSCache. new-cache + (assoc lruS item tick+) + (assoc new-lruQ item tick+) + tick+ + limitS + limitQ)))))) + (seed [_ base] + (LIRSCache. base + (into {} (for [x (range (- limitS) 0)] [x x])) + (into {} (for [x (range (- limitQ) 0)] [x x])) + 0 + limitS + limitQ)) + Object + (toString [_] + (str cache \, \space lruS \, \space lruQ \, \space tick \, \space limitS \, \space limitQ))) + +(defn clear-soft-cache! [^java.util.Map cache ^java.util.Map rcache ^ReferenceQueue rq] + (loop [r (.poll rq)] + (when r + (when-let [item (get rcache r)] + (.remove cache item)) + (.remove rcache r) + (recur (.poll rq))))) + +(defn make-reference [v rq] + (if (nil? v) + (SoftReference. ::nil rq) + (SoftReference. v rq))) + +(defcache SoftCache [^java.util.Map cache ^java.util.Map rcache rq] + CacheProtocol + (lookup [_ item] + (when-let [^SoftReference r (get cache (or item ::nil))] + (let [v (.get r)] + (if (= ::nil v) + nil + v)))) + (lookup [_ item not-found] + (if-let [^SoftReference r (get cache (or item ::nil))] + (if-let [v (.get r)] + (if (= ::nil v) + nil + v) + not-found) + not-found)) + (has? [_ item] + (let [item (or item ::nil) + ^SoftReference cell (get cache item)] + (boolean + (when cell + (not (nil? (.get cell))))))) + (hit [this item] + (clear-soft-cache! cache rcache rq) + this) + (miss [this item result] + (let [item (or item ::nil) + r (make-reference result rq)] + (.put cache item r) + (.put rcache r item) + (clear-soft-cache! cache rcache rq) + this)) + (evict [this key] + (let [key (or key ::nil) + r (get cache key)] + (when r + (.remove cache key) + (.remove rcache r)) + (clear-soft-cache! cache rcache rq) + this)) + (seed [_ base] + (let [soft-cache? (instance? SoftCache base) + cache (ConcurrentHashMap.) + rcache (ConcurrentHashMap.) + rq (ReferenceQueue.)] + (if (seq base) + (doseq [[k ^SoftReference v] base] + (let [k (or k ::nil) + r (if soft-cache? + (make-reference (.get v) rq) + (make-reference v rq))] + (.put cache k r) + (.put rcache r k)))) + (SoftCache. cache rcache rq))) + Object + (toString [_] (str cache))) + +;; Factories + +(defn basic-cache-factory + "Returns a pluggable basic cache initialized to `base`" + [base] + {:pre [(map? base)]} + (BasicCache. base)) + +(defn fifo-cache-factory + "Returns a FIFO cache with the cache and FIFO queue initialized to `base` -- + the queue is filled as the values are pulled out of `base`. If the associative + structure can guarantee ordering, then the said ordering will define the + eventual eviction order. Otherwise, there are no guarantees for the eventual + eviction ordering. + + This function takes an optional `:threshold` argument that defines the maximum number + of elements in the cache before the FIFO semantics apply (default is 32). + + If the number of elements in `base` is greater than the limit then some items + in `base` will be dropped from the resulting cache. If the associative + structure used as `base` can guarantee sorting, then the last `limit` elements + will be used as the cache seed values. Otherwise, there are no guarantees about + the elements in the resulting cache." + [base & {threshold :threshold :or {threshold 32}}] + {:pre [(number? threshold) (< 0 threshold) + (map? base)] + :post [(== threshold (count (.q ^FIFOCache %)))]} + (nextjournal.clerk.clojure.core.cache/seed (FIFOCache. {} clojure.lang.PersistentQueue/EMPTY threshold) base)) + +(defn lru-cache-factory + "Returns an LRU cache with the cache and usage-table initialized to `base` -- + each entry is initialized with the same usage value. + + This function takes an optional `:threshold` argument that defines the maximum number + of elements in the cache before the LRU semantics apply (default is 32)." + [base & {threshold :threshold :or {threshold 32}}] + {:pre [(number? threshold) (< 0 threshold) + (map? base)]} + (nextjournal.clerk.clojure.core.cache/seed (LRUCache. {} (clojure.data.priority-map/priority-map) 0 threshold) base)) + +(defn ttl-cache-factory + "Returns a TTL cache with the cache and expiration-table initialized to `base` -- + each with the same time-to-live. + + This function also allows an optional `:ttl` argument that defines the default + time in milliseconds that entries are allowed to reside in the cache." + [base & {ttl :ttl :or {ttl 2000}}] + {:pre [(number? ttl) (<= 0 ttl) + (map? base)]} + (nextjournal.clerk.clojure.core.cache/seed (TTLCacheQ. {} {} clojure.lang.PersistentQueue/EMPTY 0 ttl) base)) + +(defn lu-cache-factory + "Returns an LU cache with the cache and usage-table initialized to `base`. + + This function takes an optional `:threshold` argument that defines the maximum number + of elements in the cache before the LU semantics apply (default is 32)." + [base & {threshold :threshold :or {threshold 32}}] + {:pre [(number? threshold) (< 0 threshold) + (map? base)]} + (nextjournal.clerk.clojure.core.cache/seed (LUCache. {} (clojure.data.priority-map/priority-map) threshold) base)) + +(defn lirs-cache-factory + "Returns an LIRS cache with the S & R LRU lists set to the indicated + limits." + [base & {:keys [s-history-limit q-history-limit] + :or {s-history-limit 32 + q-history-limit 32}}] + {:pre [(number? s-history-limit) (< 0 s-history-limit) + (number? q-history-limit) (< 0 q-history-limit) + (map? base)]} + (nextjournal.clerk.clojure.core.cache/seed (LIRSCache. {} {} {} 0 s-history-limit q-history-limit) base)) + +(defn soft-cache-factory + "Returns a SoftReference cache. Cached values will be referred to with + SoftReferences, allowing the values to be garbage collected when there is + memory pressure on the JVM. + + SoftCache is a mutable cache, since it is always based on a + ConcurrentHashMap." + [base] + {:pre [(map? base)]} + (nextjournal.clerk.clojure.core.cache/seed (SoftCache. (ConcurrentHashMap.) (ConcurrentHashMap.) (ReferenceQueue.)) + base)) diff --git a/src/nextjournal/clerk/clojure/core/memoize.clj b/src/nextjournal/clerk/clojure/core/memoize.clj new file mode 100644 index 000000000..1dddf0c4d --- /dev/null +++ b/src/nextjournal/clerk/clojure/core/memoize.clj @@ -0,0 +1,509 @@ +; Copyright (c) Rich Hickey and Michael Fogus. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.core.memoize + "core.memoize is a memoization library offering functionality above + Clojure's core `memoize` function in the following ways: + + **Pluggable memoization** + + core.memoize allows for different back-end cache implmentations to + be used as appropriate without changing the memoization modus operandi. + See the `memoizer` function. + + **Manipulable memoization** + + Because core.memoize allows you to access a function's memoization store, + you do interesting things like clear it, modify it, and save it for later. + " + {:author "fogus"} + + (:require [nextjournal.clerk.clojure.core.cache :as cache])) + + + +;; Similar to clojure.lang.Delay, but will not memoize an exception and will +;; instead retry. +;; fun - the function, never nil +;; available? - indicates a memoized value is available, volatile for visibility +;; value - the value (if available) - volatile for visibility +(deftype RetryingDelay [fun ^:volatile-mutable available? ^:volatile-mutable value] + clojure.lang.IDeref + (deref [this] + ;; first check (safe with volatile flag) + (if available? + value + (locking fun + ;; second check (race condition with locking) + (if available? + value + (do + ;; fun may throw - will retry on next deref + (let [v (fun)] + ;; this ordering is important - MUST set value before setting available? + ;; or you have a race with the first check above + (set! value v) + (set! available? true) + v)))))) + clojure.lang.IPending + (isRealized [this] + available?)) + +(defn- d-lay [fun] + (->RetryingDelay fun false nil)) + +(defn- make-derefable + "If a value is not already derefable, wrap it up. + + This is used to help rebuild seed/base maps passed in to the various + caches so that they conform to core.memoize's world view." + [v] + (if (instance? clojure.lang.IDeref v) + v + (reify clojure.lang.IDeref + (deref [_] v)))) + +(defn- derefable-seed + "Given a seed/base map, ensure all the values in it are derefable." + [seed] + (into {} (for [[k v] seed] [k (make-derefable v)]))) + +;; Plugging Interface + +(deftype PluggableMemoization [f cache] + cache/CacheProtocol + (has? [_ item] + (nextjournal.clerk.clojure.core.cache/has? cache item)) + (hit [_ item] + (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/hit cache item))) + (miss [_ item result] + (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/miss cache item result))) + (evict [_ key] + (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/evict cache key))) + (lookup [_ item] + (nextjournal.clerk.clojure.core.cache/lookup cache item nil)) + (lookup [_ item not-found] + (nextjournal.clerk.clojure.core.cache/lookup cache item (delay not-found))) + (seed [_ base] + (PluggableMemoization. + f (nextjournal.clerk.clojure.core.cache/seed cache (derefable-seed base)))) + Object + (toString [_] (str cache))) + +;; # Auxilliary functions + +(def ^{:private true + :doc "Returns a function's argument transformer."} + args-fn #(or (::args-fn (meta %)) identity)) + +(defn- through* + "The basic hit/miss logic for the cache system based on `core.cache/through`. + Clojure delays are used to hold the cache value." + [cache f args item] + (nextjournal.clerk.clojure.core.cache/through + (fn [f _] (d-lay #(f args))) + #(clojure.core/apply f %) + cache + item)) + +(def ^{:private true + :doc "Returns a function's cache identity."} + cache-id #(::cache (meta %))) + + +;; # Public Utilities API + +(defn snapshot + "Returns a snapshot of a core.memo-placed memoization cache. By snapshot + you can infer that what you get is only the cache contents at a + moment in time." + [memoized-fn] + (when-let [cache (cache-id memoized-fn)] + (into {} + (for [[k v] (.cache ^PluggableMemoization @cache)] + [(vec k) @v])))) + +(defn lazy-snapshot + "Returns a lazy snapshot of a core.memo-placed memoization cache. By + lazy snapshot you can infer that what you get is only the cache contents at a + moment in time -- and, being lazy, the cache could change while you are + realizing the snapshot elements. + + Returns a sequence of key/value pairs." + [memoized-fn] + (when-let [cache (cache-id memoized-fn)] + (for [[k v] (.cache ^PluggableMemoization @cache)] + [(vec k) @v]))) + +(defn memoized? + "Returns true if a function has an core.memo-placed cache, false otherwise." + [f] + (boolean (cache-id f))) + +(defn memo-clear! + "Reaches into an core.memo-memoized function and clears the cache. This is a + destructive operation and should be used with care. + + When the second argument is a vector of input arguments, clears cache only + for argument vector. + + Keep in mind that depending on what other threads or doing, an + immediate call to `snapshot` may not yield an empty cache. That's + cool though, we've learned to deal with that stuff in Clojure by + now." + ([f] + (when-let [cache (cache-id f)] + (swap! cache (constantly (nextjournal.clerk.clojure.core.cache/seed @cache {}))))) + ([f args] + (when-let [cache (cache-id f)] + (swap! cache (constantly (nextjournal.clerk.clojure.core.cache/evict @cache args)))))) + +(defn memo-reset! + "Takes a core.memo-populated function and a map and replaces the memoization cache + with the supplied map. This is potentially some serious voodoo, + since you can effectively change the semantics of a function on the fly. + + (def id (memo identity)) + (memo-swap! id '{[13] :omg}) + (id 13) + ;=> :omg + + With great power comes ... yadda yadda yadda." + [f base] + (when-let [cache (cache-id f)] + (swap! cache + (constantly (nextjournal.clerk.clojure.core.cache/seed @cache (derefable-seed base)))))) + +(defn memo-swap! + "The 2-arity version takes a core.memo-populated function and a map and + replaces the memoization cache with the supplied map. Use `memo-reset!` + instead for replacing the cache as this 2-arity version of `memo-swap!` + should be considered deprecated. + + The 3+-arity version takes a core.memo-populated function and arguments + similar to what you would pass to `clojure.core/swap!` and performs a + `swap!` on the underlying cache. In order to satisfy core.memoize's + world view, the assumption is that you will generally be calling it like: + + (def id (memo identity)) + (memo-swap! id clojure.core.cache/miss [13] :omg) + (id 13) + ;=> :omg + + You'll nearly always use `clojure.core.cache/miss` for this operation but + you could pass any function that would work on an immutable cache, such + as `evict` or `assoc` etc. + + Be aware that `memo-swap!` assumes it can wrap each of the `results` values + in a `delay` so that items conform to `clojure.core.memoize`'s world view." + ([f base] + (when-let [cache (cache-id f)] + (swap! cache + (constantly (nextjournal.clerk.clojure.core.cache/seed @cache (derefable-seed base)))))) + ([f swap-fn args & results] + (when-let [cache (cache-id f)] + (apply swap! cache swap-fn args (map #(delay %) results))))) + +(defn memo-unwrap + [f] + (::original (meta f))) + +(defn- cached-function + "Given a function, an atom containing a (pluggable memoization cache), and + and cache key function, return a new function that behaves like the original + function except it is cached, based on its arguments, with the cache and the + original function in its metadata." + [f cache-atom ckey-fn] + (with-meta + (fn [& args] + (let [ckey (or (ckey-fn args) []) + cs (swap! cache-atom through* f args ckey) + val (nextjournal.clerk.clojure.core.cache/lookup cs ckey ::not-found)] + ;; If `lookup` returns `(delay ::not-found)`, it's likely that + ;; we ran into a timing issue where eviction and access + ;; are happening at about the same time. Therefore, we retry + ;; the `swap!` (potentially several times). + ;; + ;; core.memoize currently wraps all of its values in a `delay`. + (when val + (loop [n 0 v @val] + (if (= ::not-found v) + (when-let [v' (nextjournal.clerk.clojure.core.cache/lookup + (swap! cache-atom through* f args ckey) + ckey ::not-found)] + (when (< n 10) + (recur (inc n) @v'))) + v))))) + {::cache cache-atom + ::original f})) + +;; # Public memoization API + +(defn memoizer + "Build a pluggable memoized version of a function. Given a function and a + (pluggable memoized) cache, and an optional seed (hash map of arguments to + return values), return a cached version of that function. + + If you want to build your own cached function, perhaps with combined caches + or customized caches, this is the preferred way to do so now." + ([f cache] + (let [cache (atom (PluggableMemoization. f cache)) + ckey-fn (args-fn f)] + (cached-function f cache ckey-fn))) + ([f cache seed] + (let [cache (atom (nextjournal.clerk.clojure.core.cache/seed (PluggableMemoization. f cache) + (derefable-seed seed))) + ckey-fn (args-fn f)] + (cached-function f cache ckey-fn)))) + +(defn build-memoizer + "Builds a function that, given a function, returns a pluggable memoized + version of it. `build-memoizer` takes a cache factory function, and the + arguments to that factory function -- at least one of those arguments + should be the function to be memoized (it's usually the first argument). + + `memoizer` above is a simpler version of `build-memoizer` that 'does the + right thing' with a cache and a seed hash map. `build-memoizer` remains + for backward compatibility but should be considered deprecated." + ([cache-factory f & args] + (let [cache (atom (apply cache-factory f args)) + ckey-fn (args-fn f)] + (cached-function f cache ckey-fn)))) + +(defn memo + "Used as a more flexible alternative to Clojure's core `memoization` + function. Memoized functions built using `memo` will respond to + the core.memo manipulable memoization utilities. As a nice bonus, + you can use `memo` in place of `memoize` without any additional + changes, with the added guarantee that the memoized function will + only be called once for a given sequence of arguments (`memoize` + can call the function multiple times when concurrent calls are + made with the same sequence of arguments). + + The default way to use this function is to simply supply a function + that will be memoized. Additionally, you may also supply a map + of the form `'{[42] 42, [108] 108}` where keys are a vector + mapping expected argument values to arity positions. The map values + are the return values of the memoized function. + + If the supplied function has metadata containing an + `:clojure.core.memoize/args-fn` key, the value is assumed to be a + function that should be applied to the arguments to produce a + subset or transformed sequence of arguments that are used for the + key in the cache (the full, original arguments will still be used + to call the function). This allows you to memoize functions where + one or more arguments are irrelevant for memoization, such as the + `clojure.java.jdbc` functions, whose first argument may include + a (mutable) JDBC `Connection` object: + + (memo/memo (with-meta jdbc/execute! {::memo/args-fn rest})) + + You can access the memoization cache directly via the `:clojure.core.memoize/cache` key + on the memoized function's metadata. However, it is advised to + use the core.memo primitives instead as implementation details may + change over time." + ([f] (memo f {})) + ([f seed] + (memoizer f (cache/basic-cache-factory {}) seed))) + +;; ## Utilities + +(defn ^{:private true} !! [c] + (println "WARNING - Deprecated construction method for" + c + "cache; prefered way is:" + (str "(clojure.core.memoize/" c " function <:" c "/threshold num>)"))) + +(defmacro ^{:private true} def-deprecated [nom ds & arities] + `(defn ~(symbol (str "memo-" (name nom))) ~ds + ~@(for [[args body] arities] + (list args `(!! (quote ~nom)) body)))) + +(defmacro ^{:private true} massert [condition msg] + `(when-not ~condition + (throw (new AssertionError (str "clojure.core.memoize/" ~msg "\n" (pr-str '~condition)))))) + +(defmacro ^{:private true} check-args [nom f base key threshold] + (when *assert* + (let [good-key (keyword nom "threshold") + key-error `(str "Incorrect threshold key " ~key) + fun-error `(str ~nom " expects a function as its first argument; given " ~f) + thresh-error `(str ~nom " expects an integer for its " ~good-key " argument; given " ~threshold)] + `(do (massert (= ~key ~good-key) ~key-error) + (massert (some #{clojure.lang.IFn + clojure.lang.AFn + java.lang.Runnable + java.util.concurrent.Callable} + (ancestors (class ~f))) + ~fun-error) + (massert (number? ~threshold) ~thresh-error))))) + +;; ## Main API functions + +;; ### FIFO + +(def-deprecated fifo + "DEPRECATED: Please use clojure.core.memoize/fifo instead." + ([f] (memo-fifo f 32 {})) + ([f limit] (memo-fifo f limit {})) + ([f limit base] + (memoizer f (cache/fifo-cache-factory {} :threshold limit) base))) + +(defn fifo + "Works the same as the basic memoization function (i.e. `memo` + and `core.memoize` except when a given threshold is breached. + + Observe the following: + + (require '[clojure.core.memoize :as memo]) + + (def id (memo/fifo identity :fifo/threshold 2)) + + (id 42) + (id 43) + (snapshot id) + ;=> {[42] 42, [43] 43} + + As you see, the limit of `2` has not been breached yet, but + if you call again with another value, then it is: + + (id 44) + (snapshot id) + ;=> {[44] 44, [43] 43} + + That is, the oldest entry `42` is pushed out of the + memoization cache. This is the standard **F**irst **I**n + **F**irst **O**ut behavior." + ([f] (fifo f {} :fifo/threshold 32)) + ([f base] (fifo f base :fifo/threshold 32)) + ([f tkey threshold] (fifo f {} tkey threshold)) + ([f base key threshold] + (check-args "fifo" f base key threshold) + (memoizer f (cache/fifo-cache-factory {} :threshold threshold) base))) + +;; ### LRU + +(def-deprecated lru + "DEPRECATED: Please use clojure.core.memoize/lru instead." + ([f] (memo-lru f 32)) + ([f limit] (memo-lru f limit {})) + ([f limit base] + (memoizer f (cache/lru-cache-factory {} :threshold limit) base))) + +(defn lru + "Works the same as the basic memoization function (i.e. `memo` + and `core.memoize` except when a given threshold is breached. + + Observe the following: + + (require '[clojure.core.memoize :as memo]) + + (def id (memo/lru identity :lru/threshold 2)) + + (id 42) + (id 43) + (snapshot id) + ;=> {[42] 42, [43] 43} + + At this point the cache has not yet crossed the set threshold + of `2`, but if you execute yet another call the story will + change: + + (id 44) + (snapshot id) + ;=> {[44] 44, [43] 43} + + At this point the operation of the LRU cache looks exactly + the same at the FIFO cache. However, the difference becomes + apparent on further use: + + (id 43) + (id 0) + (snapshot id) + ;=> {[0] 0, [43] 43} + + As you see, once again calling `id` with the argument `43` + will expose the LRU nature of the underlying cache. That is, + when the threshold is passed, the cache will expel the + **L**east **R**ecently **U**sed element in favor of the new." + ([f] (lru f {} :lru/threshold 32)) + ([f base] (lru f base :lru/threshold 32)) + ([f tkey threshold] (lru f {} tkey threshold)) + ([f base key threshold] + (check-args "lru" f base key threshold) + (memoizer f (cache/lru-cache-factory {} :threshold threshold) base))) + +;; ### TTL + +(def-deprecated ttl + "DEPRECATED: Please use clojure.core.memoize/ttl instead." + ([f] (memo-ttl f 3000 {})) + ([f limit] (memo-ttl f limit {})) + ([f limit base] + (memoizer f (cache/ttl-cache-factory {} :ttl limit) base))) + +(defn ttl + "Unlike many of the other core.memo memoization functions, + `memo-ttl`'s cache policy is time-based rather than algorithmic + or explicit. When memoizing a function using `memo-ttl` you + should provide a **T**ime **T**o **L**ive parameter in + milliseconds. + + (require '[clojure.core.memoize :as memo]) + + (def id (memo/ttl identity :ttl/threshold 5000)) + + (id 42) + (snapshot id) + ;=> {[42] 42} + + ... wait 5 seconds ... + (id 43) + (snapshot id) + ;=> {[43] 43} + + The expired cache entries will be removed on each cache **miss**." + ([f] (ttl f {} :ttl/threshold 32)) + ([f base] (ttl f base :ttl/threshold 32)) + ([f tkey threshold] (ttl f {} tkey threshold)) + ([f base key threshold] + (check-args "ttl" f base key threshold) + (memoizer f (cache/ttl-cache-factory {} :ttl threshold) base))) + +;; ### LU + +(def-deprecated lu + "DEPRECATED: Please use clojure.core.memoize/lu instead." + ([f] (memo-lu f 32)) + ([f limit] (memo-lu f limit {})) + ([f limit base] + (memoizer f (cache/lu-cache-factory {} :threshold limit) base))) + +(defn lu + "Similar to the implementation of memo-lru, except that this + function removes all cache values whose usage value is + smallest: + + (require '[clojure.core.memoize :as memo]) + + (def id (memo/lu identity :lu/threshold 3)) + + (id 42) + (id 42) + (id 43) + (id 44) + (snapshot id) + ;=> {[44] 44, [42] 42} + + The **L**east **U**sed values are cleared on cache misses." + ([f] (lu f {} :lu/threshold 32)) + ([f base] (lu f base :lu/threshold 32)) + ([f tkey threshold] (lu f {} tkey threshold)) + ([f base key threshold] + (check-args "lu" f base key threshold) + (memoizer f (cache/lu-cache-factory {} :threshold threshold) base))) diff --git a/src/nextjournal/clerk/clojure/data/priority_map.clj b/src/nextjournal/clerk/clojure/data/priority_map.clj new file mode 100644 index 000000000..62f6613e7 --- /dev/null +++ b/src/nextjournal/clerk/clojure/data/priority_map.clj @@ -0,0 +1,510 @@ +;; Copyright (c) Mark Engelberg, Rich Hickey and contributors. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +;; A priority map is a map from items to priorities, +;; offering queue-like peek/pop as well as the map-like ability to +;; easily reassign priorities and other conveniences. +;; by Mark Engelberg (mark.engelberg@gmail.com) +;; Last update - September 19, 2021 + +(ns + ^{:author "Mark Engelberg", + :doc "A priority map is very similar to a sorted map, but whereas a sorted map produces a +sequence of the entries sorted by key, a priority map produces the entries sorted by value. +In addition to supporting all the functions a sorted map supports, a priority map +can also be thought of as a queue of [item priority] pairs. To support usage as +a versatile priority queue, priority maps also support conj/peek/pop operations. + +The standard way to construct a priority map is with priority-map: +user=> (def p (priority-map :a 2 :b 1 :c 3 :d 5 :e 4 :f 3)) +#'user/p +user=> p +{:b 1, :a 2, :c 3, :f 3, :e 4, :d 5} + +So :b has priority 1, :a has priority 2, and so on. +Notice how the priority map prints in an order sorted by its priorities (i.e., the map's values) + +We can use assoc to assign a priority to a new item: +user=> (assoc p :g 1) +{:b 1, :g 1, :a 2, :c 3, :f 3, :e 4, :d 5} + +or to assign a new priority to an extant item: +user=> (assoc p :c 4) +{:b 1, :a 2, :f 3, :c 4, :e 4, :d 5} + +We can remove an item from the priority map: +user=> (dissoc p :e) +{:b 1, :a 2, :c 3, :f 3, :d 5} + +An alternative way to add to the priority map is to conj a [item priority] pair: +user=> (conj p [:g 0]) +{:g 0, :b 1, :a 2, :c 3, :f 3, :e 4, :d 5} + +or use into: +user=> (into p [[:g 0] [:h 1] [:i 2]]) +{:g 0, :b 1, :h 1, :a 2, :i 2, :c 3, :f 3, :e 4, :d 5} + +Priority maps are countable: +user=> (count p) +6 + +Like other maps, equivalence is based not on type, but on contents. +In other words, just as a sorted-map can be equal to a hash-map, +so can a priority-map. +user=> (= p {:b 1, :a 2, :c 3, :f 3, :e 4, :d 5}) +true + +You can test them for emptiness: +user=> (empty? (priority-map)) +true +user=> (empty? p) +false + +You can test whether an item is in the priority map: +user=> (contains? p :a) +true +user=> (contains? p :g) +false + +It is easy to look up the priority of a given item, using any of the standard map mechanisms: +user=> (get p :a) +2 +user=> (get p :g 10) +10 +user=> (p :a) +2 +user=> (:a p) +2 + +Priority maps derive much of their utility by providing priority-based seq. +Note that no guarantees are made about the order in which items of the same priority appear. +user=> (seq p) +([:b 1] [:a 2] [:c 3] [:f 3] [:e 4] [:d 5]) +Because no guarantees are made about the order of same-priority items, note that +rseq might not be an exact reverse of the seq. It is only guaranteed to be in +descending order. +user=> (rseq p) +([:d 5] [:e 4] [:c 3] [:f 3] [:a 2] [:b 1]) + +This means first/rest/next/for/map/etc. all operate in priority order. +user=> (first p) +[:b 1] +user=> (rest p) +([:a 2] [:c 3] [:f 3] [:e 4] [:d 5]) + +Priority maps also support subseq and rsubseq, however, *you must use the subseq and rsubseq +defined in the clojure.data.priority-map namespace*, which patches longstanding JIRA issue +[CLJ-428](https://clojure.atlassian.net/browse/CLJ-428). These patched versions +of subseq and rsubseq will work on Clojure's other sorted collections as well, so you can +use them as a drop-in replacement for the subseq and rsubseq found in core. +user=> (subseq p < 3) +([:b 1] [:a 2]) +user=> (subseq p >= 3) +([:c 3] [:f 3] [:e 4] [:d 5]) +user=> (subseq p >= 2 < 4) +([:a 2] [:c 3] [:f 3]) +user=> (rsubseq p < 4) +([:c 3] [:f 3] [:a 2] [:b 1]) +user=> (rsubseq p >= 4) +([:d 5] [:e 4]) + +Priority maps support metadata: +user=> (meta (with-meta p {:extra :info})) +{:extra :info} + +But perhaps most importantly, priority maps can also function as priority queues. +peek, like first, gives you the first [item priority] pair in the collection. +pop removes the first [item priority] from the collection. +(Note that unlike rest, which returns a seq, pop returns a priority map). + +user=> (peek p) +[:b 1] +user=> (pop p) +{:a 2, :c 3, :f 3, :e 4, :d 5} + +It is also possible to use a custom comparator: +user=> (priority-map-by > :a 1 :b 2 :c 3) +{:c 3, :b 2, :a 1} + +Sometimes, it is desirable to have a map where the values contain more information +than just the priority. For example, let's say you want a map like: +{:a [2 :apple], :b [1 :banana], :c [3 :carrot]} +and you want to sort the map by the numeric priority found in the pair. + +A common mistake is to try to solve this with a custom comparator: +(priority-map-by + (fn [[priority1 _] [priority2 _]] (< priority1 priority2)) + :a [2 :apple], :b [1 :banana], :c [3 :carrot]) + +This will not work! Although it may appear to work with these particular values, it is not safe. +In Clojure, like Java, all comparators must be *total orders*, +meaning that you can't have a tie unless the objects you are comparing are +in fact equal. The above comparator breaks that rule because objects such as +`[2 :apple]` and `[2 :apricot]` would tie, but are not equal. + +The correct way to construct such a priority map is by specifying a keyfn, which is used +to extract the true priority from the priority map's vals. (Note: It might seem a little odd +that the priority-extraction function is called a *key*fn, even though it is applied to the +map's values. This terminology is based on the docstring of clojure.core/sort-by, which +uses `keyfn` for the function which extracts the sort order.) + +In the above example, + +user=> (priority-map-keyfn first :a [2 :apple], :b [1 :banana], :c [3 :carrot]) +{:b [1 :banana], :a [2 :apple], :c [3 :carrot]} + +You can also combine a keyfn with a comparator that operates on the extracted priorities: + +user=> (priority-map-keyfn-by + first > + :a [2 :apple], :b [1 :banana], :c [3 :carrot]) +{:c [3 :carrot], :a [2 :apple], :b [1 :banana]} + + + +All of these operations are efficient. Generally speaking, most operations +are O(log n) where n is the number of distinct priorities. Some operations +(for example, straightforward lookup of an item's priority, or testing +whether a given item is in the priority map) are as efficient +as Clojure's built-in map. + +The key to this efficiency is that internally, not only does the priority map store +an ordinary hash map of items to priority, but it also stores a sorted map that +maps priorities to sets of items with that priority. + +A typical textbook priority queue data structure supports at the ability to add +a [item priority] pair to the queue, and to pop/peek the next [item priority] pair. +But many real-world applications of priority queues require more features, such +as the ability to test whether something is already in the queue, or to reassign +a priority. For example, a standard formulation of Dijkstra's algorithm requires the +ability to reduce the priority number associated with a given item. Once you +throw persistence into the mix with the desire to adjust priorities, the traditional +structures just don't work that well. + +This particular blend of Clojure's built-in hash sets, hash maps, and sorted maps +proved to be a great way to implement an especially flexible persistent priority queue. + +Connoisseurs of algorithms will note that this structure's peek operation is not O(1) as +it would be if based upon a heap data structure, but I feel this is a small concession for +the blend of persistence, priority reassignment, and priority-sorted seq, which can be +quite expensive to achieve with a heap (I did actually try this for comparison). Furthermore, +this peek's logarithmic behavior is quite good (on my computer I can do a million +peeks at a priority map with a million items in 750ms). Also, consider that peek and pop +usually follow one another, and even with a heap, pop is logarithmic. So the net combination +of peek and pop is not much different between this versatile formulation of a priority map and +a more limited heap-based one. In a nutshell, peek, although not O(1), is unlikely to be the +bottleneck in your program. + +All in all, I hope you will find priority maps to be an easy-to-use and useful addition +to Clojure's assortment of built-in maps (hash-map and sorted-map). +"} + nextjournal.clerk.clojure.data.priority-map + (:refer-clojure :exclude [subseq rsubseq]) + (:import clojure.lang.MapEntry java.util.Map clojure.lang.PersistentTreeMap)) + +(declare pm-empty) + +(defmacro apply-keyfn [x] + `(if ~'keyfn (~'keyfn ~x) ~x)) + +(defmacro ^:private compile-if [test then else] + (if (eval test) + then + else)) + +;; We create a patched version of subseq and rsubseq from core, that works on ordinary sorted collections, as well as priority maps +;; See https://dev.clojure.org/jira/browse/CLJ-428 + +(defn mk-bound-fn + {:private true} + [^clojure.lang.Sorted sc test key] + (fn [e] (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) + +(defn subseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + ([^clojure.lang.Sorted sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{> >=} test) + (when-let [[e :as s] (. sc seqFrom key true)] + (seq (drop-while #(not (include %)) s))) + (seq (take-while include (. sc seq true)))))) + ([^clojure.lang.Sorted sc start-test start-key end-test end-key] + (when-let [[e :as s] (. sc seqFrom start-key true)] + (seq (take-while (mk-bound-fn sc end-test end-key) + (drop-while (complement (mk-bound-fn sc start-test start-key)) s)))))) + +(defn rsubseq + "sc must be a sorted collection, test(s) one of <, <=, > or + >=. Returns a reverse seq of those entries with keys ek for + which (test (.. sc comparator (compare ek key)) 0) is true" + ([^clojure.lang.Sorted sc test key] + (let [include (mk-bound-fn sc test key)] + (if (#{< <=} test) + (when-let [[e :as s] (. sc seqFrom key false)] + (seq (drop-while #(not (include %)) s))) + (seq (take-while include (. sc seq false)))))) + ([^clojure.lang.Sorted sc start-test start-key end-test end-key] + (when-let [[e :as s] (. sc seqFrom end-key false)] + (seq (take-while (mk-bound-fn sc start-test start-key) + (drop-while (complement (mk-bound-fn sc end-test end-key)) s)))))) + +;; A Priority Map is comprised of a sorted map that maps priorities to hash sets of items +;; with that priority (priority->set-of-items), +;; as well as a hash map that maps items to priorities (item->priority) +;; Priority maps may also have metadata +;; Priority maps can also have a keyfn which is applied to the "priorities" found as values in +;; the item->priority map to get the actual sortable priority keys used in priority->set-of-items. + +(deftype PersistentPriorityMap [priority->set-of-items item->priority _meta keyfn] + Object + (toString [this] (str (.seq this))) + + clojure.lang.ILookup + ;; valAt gives (get pm key) and (get pm key not-found) behavior + (valAt [this item] (get item->priority item)) + (valAt [this item not-found] (get item->priority item not-found)) + + clojure.lang.IPersistentMap + (count [this] (count item->priority)) + + (assoc [this item priority] + (let [current-priority (get item->priority item nil)] + (if current-priority + ;;Case 1 - item is already in priority map, so this is a reassignment + (if (= current-priority priority) + ;;Subcase 1 - no change in priority, do nothing + this + (let [priority-key (apply-keyfn priority) + current-priority-key (apply-keyfn current-priority) + item-set (get priority->set-of-items current-priority-key)] + (if (= (count item-set) 1) + ;;Subcase 2 - it was the only item of this priority + ;;so remove old priority entirely + ;;and conj item onto new priority's set + (PersistentPriorityMap. + (assoc (dissoc priority->set-of-items current-priority-key) + priority-key (conj (get priority->set-of-items priority-key #{}) item)) + (assoc item->priority item priority) + (meta this) + keyfn) + ;;Subcase 3 - there were many items associated with the item's original priority, + ;;so remove it from the old set and conj it onto the new one. + (PersistentPriorityMap. + (assoc priority->set-of-items + current-priority-key (disj (get priority->set-of-items current-priority-key) item) + priority-key (conj (get priority->set-of-items priority-key #{}) item)) + (assoc item->priority item priority) + (meta this) + keyfn)))) + ;; Case 2: Item is new to the priority map, so just add it. + (let [priority-key (apply-keyfn priority)] + (PersistentPriorityMap. + (assoc priority->set-of-items + priority-key (conj (get priority->set-of-items priority-key #{}) item)) + (assoc item->priority item priority) + (meta this) + keyfn))))) + + (empty [this] (PersistentPriorityMap. (empty priority->set-of-items) {} _meta keyfn)) + + ;; cons defines conj behavior + (cons [this e] + (if (map? e) + (into this e) + (let [[item priority] e] (.assoc this item priority)))) + + ;; Like sorted maps, priority maps are equal to other maps provided + ;; their key-value pairs are the same. + (equiv [this o] (= item->priority o)) + (hashCode [this] (.hashCode item->priority)) + (equals [this o] (or (identical? this o) (.equals item->priority o))) + + ;;containsKey implements (contains? pm k) behavior + (containsKey [this item] (contains? item->priority item)) + + (entryAt [this k] + (let [v (.valAt this k this)] + (when-not (identical? v this) + (MapEntry. k v)))) + + (seq [this] + (if keyfn + (seq (for [[priority item-set] priority->set-of-items, item item-set] + (MapEntry. item (item->priority item)))) + (seq (for [[priority item-set] priority->set-of-items, item item-set] + (MapEntry. item priority))))) + + ;;without implements (dissoc pm k) behavior + (without + [this item] + (let [priority (item->priority item ::not-found)] + (if (= priority ::not-found) + ;; If item is not in map, return the map unchanged. + this + (let [priority-key (apply-keyfn priority) + item-set (priority->set-of-items priority-key)] + (if (= (count item-set) 1) + ;;If it is the only item with this priority, remove that priority's set completely + (PersistentPriorityMap. (dissoc priority->set-of-items priority-key) + (dissoc item->priority item) + (meta this) + keyfn) + ;;Otherwise, just remove the item from the priority's set. + (PersistentPriorityMap. + (assoc priority->set-of-items priority-key (disj item-set item)), + (dissoc item->priority item) + (meta this) + keyfn)))))) + + clojure.lang.IHashEq + (hasheq [this] + (compile-if (resolve 'clojure.core/hash-unordered-coll) + (hash-unordered-coll this) + (.hashCode this))) + + java.io.Serializable ;Serialization comes for free with the other things implemented + clojure.lang.MapEquivalence + Map ;Makes this compatible with java's map + (size [this] (count item->priority)) + (isEmpty [this] (zero? (count item->priority))) + (containsValue [this v] + (if keyfn + (some (partial = v) (vals this)) ; no shortcut if there is a keyfn + (contains? priority->set-of-items v))) + (get [this k] (.valAt this k)) + (put [this k v] (throw (UnsupportedOperationException.))) + (remove [this k] (throw (UnsupportedOperationException.))) + (putAll [this m] (throw (UnsupportedOperationException.))) + (clear [this] (throw (UnsupportedOperationException.))) + (keySet [this] (set (keys this))) + (values [this] (vals this)) + (entrySet [this] (set this)) + + Iterable + (iterator [this] (clojure.lang.SeqIterator. (seq this))) + + clojure.core.protocols/IKVReduce + (kv-reduce [this f init] + (if keyfn + (reduce-kv (fn [a k v] + (reduce (fn [a v] (f a v (item->priority v))) a v)) + init priority->set-of-items) + (reduce-kv (fn [a k v] + (reduce (fn [a v] (f a v k)) a v)) + init priority->set-of-items))) + + clojure.lang.IPersistentStack + (peek [this] + (when-not (.isEmpty this) + (let [f (first priority->set-of-items) + item (first (val f))] + (if keyfn + (MapEntry. item (item->priority item)) + (MapEntry. item (key f)))))) + + (pop [this] + (if (.isEmpty this) (throw (IllegalStateException. "Can't pop empty priority map")) + (let [f (first priority->set-of-items), + item-set (val f) + item (first item-set), + priority-key (key f)] + (if (= (count item-set) 1) + ;;If the first item is the only item with its priority, remove that priority's set completely + (PersistentPriorityMap. + (dissoc priority->set-of-items priority-key) + (dissoc item->priority item) + (meta this) + keyfn) + ;;Otherwise, just remove the item from the priority's set. + (PersistentPriorityMap. + (assoc priority->set-of-items priority-key (disj item-set item)), + (dissoc item->priority item) + (meta this) + keyfn))))) + + clojure.lang.IFn + ;;makes priority map usable as a function + (invoke [this k] (.valAt this k)) + (invoke [this k not-found] (.valAt this k not-found)) + + clojure.lang.IObj + ;;adds metadata support + (meta [this] _meta) + (withMeta [this m] (PersistentPriorityMap. priority->set-of-items item->priority m keyfn)) + + clojure.lang.Reversible + (rseq [this] + (if keyfn + (seq (for [[priority item-set] (rseq priority->set-of-items), item item-set] + (MapEntry. item (item->priority item)))) + (seq (for [[priority item-set] (rseq priority->set-of-items), item item-set] + (MapEntry. item priority))))) + + clojure.lang.Sorted + ;; These methods provide support for subseq and rsubseq + (comparator [this] (.comparator ^PersistentTreeMap priority->set-of-items)) + (entryKey [this entry] (if keyfn (keyfn (val entry)) (val entry))) + (seqFrom [this k ascending] + (let [sets (if ascending (subseq priority->set-of-items >= k) (rsubseq priority->set-of-items <= k))] + (if keyfn + (seq (for [[priority item-set] sets, item item-set] + (MapEntry. item (item->priority item)))) + (seq (for [[priority item-set] sets, item item-set] + (MapEntry. item priority)))))) + (seq [this ascending] + (if ascending (seq this) (rseq this)))) + +(def ^:private pm-empty (PersistentPriorityMap. (sorted-map) {} {} nil)) +(defn- pm-empty-by [comparator] (PersistentPriorityMap. (sorted-map-by comparator) {} {} nil)) +(defn- pm-empty-keyfn + ([keyfn] (PersistentPriorityMap. (sorted-map) {} {} keyfn)) + ([keyfn comparator] (PersistentPriorityMap. (sorted-map-by comparator) {} {} keyfn))) + + +;; The main way to build priority maps +(defn priority-map + "Usage: (priority-map key val key val ...) + Returns a new priority map with optional supplied mappings. + (priority-map) returns an empty priority map." + [& keyvals] + {:pre [(even? (count keyvals))]} + (reduce conj pm-empty (partition 2 keyvals))) + +(defn priority-map-by + "Usage: (priority-map comparator key val key val ...) + Returns a new priority map with custom comparator and optional supplied mappings. + (priority-map-by comparator) yields an empty priority map with custom comparator." + [comparator & keyvals] + {:pre [(even? (count keyvals))]} + (reduce conj (pm-empty-by comparator) (partition 2 keyvals))) + +(defn priority-map-keyfn + "Usage: (priority-map-keyfn keyfn key val key val ...) + Returns a new priority map with custom keyfn and optional supplied mappings. + The priority is determined by comparing (keyfn val). + (priority-map-keyfn keyfn) yields an empty priority map with custom keyfn." + [keyfn & keyvals] + {:pre [(even? (count keyvals))]} + (reduce conj (pm-empty-keyfn keyfn) (partition 2 keyvals))) + +(defn priority-map-keyfn-by + "Usage: (priority-map-keyfn-by keyfn comparator key val key val ...) + Returns a new priority map with custom keyfn, custom comparator, and optional supplied mappings. + The priority is determined by comparing (keyfn val). + (priority-map-keyfn-by keyfn comparator) yields an empty priority map with custom keyfn and comparator." + [keyfn comparator & keyvals] + {:pre [(even? (count keyvals))]} + (reduce conj (pm-empty-keyfn keyfn comparator) (partition 2 keyvals))) + +(defn priority->set-of-items + "Takes a priority map p, and returns a sorted map from each priority + to the set of items with that priority in p" + [^PersistentPriorityMap p] + (.priority->set-of-items p)) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj new file mode 100644 index 000000000..8aa0844e7 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj @@ -0,0 +1,628 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.jvm + "Analyzer for clojure code, extends tools.analyzer with JVM specific passes/forms" + (:refer-clojure :exclude [macroexpand-1 macroexpand]) + (:require [clojure.tools.analyzer + :as ana + :refer [analyze analyze-in-env wrapping-meta analyze-fn-method] + :rename {analyze -analyze}] + + [clojure.tools.analyzer + [utils :refer [ctx resolve-sym -source-info resolve-ns obj? dissoc-env butlast+last mmerge]] + [ast :refer [walk prewalk postwalk] :as ast] + [env :as env :refer [*env*]] + [passes :refer [schedule]]] + + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer :all :as u :exclude [box specials]] + + [clojure.tools.analyzer.passes + [source-info :refer [source-info]] + [trim :refer [trim]] + [elide-meta :refer [elide-meta elides]] + [warn-earmuff :refer [warn-earmuff]] + [uniquify :refer [uniquify-locals]]] + + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [analyze-host-expr :refer [analyze-host-expr]] + [box :refer [box]] + [constant-lifter :refer [constant-lift]] + [classify-invoke :refer [classify-invoke]] + [validate :refer [validate]] + [infer-tag :refer [infer-tag]] + [validate-loop-locals :refer [validate-loop-locals]] + [warn-on-reflection :refer [warn-on-reflection]] + [emit-form :refer [emit-form]]] + + [clojure.java.io :as io] + [clojure.tools.reader :as reader] + [clojure.tools.reader.reader-types :as readers] + + [nextjournal.clerk.clojure.core.memoize :refer [memo-clear!]]) + (:import (clojure.lang IObj RT Compiler Var) + java.net.URL)) + +(set! *warn-on-reflection* true) + +(def ns-safe-macro + "Clojure macros that are known to not alter namespaces" + #{#'clojure.core/-> + #'clojure.core/->> + #'clojure.core/.. + #'clojure.core/and + #'clojure.core/as-> + #'clojure.core/assert + #'clojure.core/case + #'clojure.core/cond + #'clojure.core/cond-> + #'clojure.core/cond->> + #'clojure.core/condp + #'clojure.core/defn + #'clojure.core/defn- + #'clojure.core/delay + #'clojure.core/doseq + #'clojure.core/dosync + #'clojure.core/dotimes + #'clojure.core/doto + #'clojure.core/fn + #'clojure.core/for + #'clojure.core/future + #'clojure.core/if-let + #'clojure.core/if-not + #'clojure.core/lazy-seq + #'clojure.core/let + #'clojure.core/letfn + #'clojure.core/loop + #'clojure.core/or + #'clojure.core/reify + #'clojure.core/some-> + #'clojure.core/some->> + #'clojure.core/sync + #'clojure.core/time + #'clojure.core/when + #'clojure.core/when-let + #'clojure.core/when-not + #'clojure.core/while + #'clojure.core/with-open + #'clojure.core/with-out-str + }) + +(def specials + "Set of the special forms for clojure in the JVM" + (into ana/specials + '#{monitor-enter monitor-exit clojure.core/import* reify* deftype* case*})) + +(defn build-ns-map [] + (into {} (mapv #(vector (ns-name %) + {:mappings (merge (ns-map %) {'in-ns #'clojure.core/in-ns + 'ns #'clojure.core/ns}) + :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v))) + {} (ns-aliases %)) + :ns (ns-name %)}) + (all-ns)))) + +(defn update-ns-map! [] + ((get (env/deref-env) :update-ns-map! #()))) + +(defn global-env [] + (atom {:namespaces (build-ns-map) + + :update-ns-map! (fn update-ns-map! [] + (swap! *env* assoc-in [:namespaces] (build-ns-map)))})) + +(defn empty-env + "Returns an empty env map" + [] + {:context :ctx/expr + :locals {} + :ns (ns-name *ns*)}) + +(defn desugar-symbol [form env] + (let [sym-ns (namespace form)] + (if-let [target (and sym-ns + (not (resolve-ns (symbol sym-ns) env)) + (maybe-class-literal sym-ns))] ;; Class/field + (let [opname (name form)] + (if (and (= (count opname) 1) + (Character/isDigit (char (first opname)))) + form ;; Array/ + (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field) + (meta form)))) + form))) + +(defn desugar-host-expr [form env] + (let [[op & expr] form] + (if (symbol? op) + (let [opname (name op) + opns (namespace op)] + (if-let [target (and opns + (not (resolve-ns (symbol opns) env)) + (maybe-class-literal opns))] ; (class/field ..) + + (let [op (symbol opname)] + (with-meta (list '. target (if (zero? (count expr)) + op + (list* op expr))) + (meta form))) + + (cond + (.startsWith opname ".") ; (.foo bar ..) + (let [[target & args] expr + target (if-let [target (maybe-class-literal target)] + (with-meta (list 'do target) + {:tag 'java.lang.Class}) + target) + args (list* (symbol (subs opname 1)) args)] + (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is + (first args) args)) ;; a method call or a field access + (meta form))) + + (.endsWith opname ".") ;; (class. ..) + (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr) + (meta form)) + + :else form))) + form))) + +(defn macroexpand-1 + "If form represents a macro form or an inlineable function,returns its expansion, + else returns form." + ([form] (macroexpand-1 form (empty-env))) + ([form env] + (env/ensure (global-env) + (cond + + (seq? form) + (let [[op & args] form] + (if (specials op) + form + (let [v (resolve-sym op env) + m (meta v) + local? (-> env :locals (get op)) + macro? (and (not local?) (:macro m)) ;; locals shadow macros + inline-arities-f (:inline-arities m) + inline? (and (not local?) + (or (not inline-arities-f) + (inline-arities-f (count args))) + (:inline m)) + t (:tag m)] + (cond + + macro? + (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args) + (when-not (ns-safe-macro v) + (update-ns-map!)) + (if (obj? res) + (vary-meta res merge (meta form)) + res)) + + inline? + (let [res (apply inline? args)] + (update-ns-map!) + (if (obj? res) + (vary-meta res merge + (and t {:tag t}) + (meta form)) + res)) + + :else + (desugar-host-expr form env))))) + + (symbol? form) + (desugar-symbol form env) + + :else + form)))) + +(defn qualify-arglists [arglists] + (vary-meta arglists merge + (when-let [t (:tag (meta arglists))] + {:tag (if (or (string? t) + (u/specials (str t)) + (u/special-arrays (str t))) + t + (if-let [c (maybe-class t)] + (let [new-t (-> c .getName symbol)] + (if (= new-t t) + t + (with-meta new-t {::qualified? true}))) + t))}))) + +(defn create-var + "Creates a Var for sym and returns it. + The Var gets interned in the env namespace." + [sym {:keys [ns]}] + (let [v (get-in (env/deref-env) [:namespaces ns :mappings (symbol (name sym))])] + (if (and v (or (class? v) + (= ns (ns-name (.ns ^Var v) )))) + v + (let [meta (dissoc (meta sym) :inline :inline-arities :macro) + meta (if-let [arglists (:arglists meta)] + (assoc meta :arglists (qualify-arglists arglists)) + meta)] + (intern ns (with-meta sym meta)))))) + +(defn parse-monitor-enter + [[_ target :as form] env] + (when-not (= 2 (count form)) + (throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form))) + (merge {:form form} + (-source-info form env))))) + {:op :monitor-enter + :env env + :form form + :target (-analyze target (ctx env :ctx/expr)) + :children [:target]}) + +(defn parse-monitor-exit + [[_ target :as form] env] + (when-not (= 2 (count form)) + (throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form))) + (merge {:form form} + (-source-info form env))))) + {:op :monitor-exit + :env env + :form form + :target (-analyze target (ctx env :ctx/expr)) + :children [:target]}) + +(defn parse-import* + [[_ class :as form] env] + (when-not (= 2 (count form)) + (throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form))) + (merge {:form form} + (-source-info form env))))) + {:op :import + :env env + :form form + :class class}) + +(defn analyze-method-impls + [[method [this & params :as args] & body :as form] env] + (when-let [error-msg (cond + (not (symbol? method)) + (str "Method method must be a symbol, had: " (class method)) + (not (vector? args)) + (str "Parameter listing should be a vector, had: " (class args)) + (not (first args)) + (str "Must supply at least one argument for 'this' in: " method))] + (throw (ex-info error-msg + (merge {:form form + :in (:this env) + :method method + :args args} + (-source-info form env))))) + (let [meth (cons (vec params) body) ;; this is an implicit arg + this-expr {:name this + :env env + :form this + :op :binding + :o-tag (:this env) + :tag (:this env) + :local :this} + env (assoc-in (dissoc env :this) [:locals this] (dissoc-env this-expr)) + method-expr (analyze-fn-method meth env)] + (assoc (dissoc method-expr :variadic?) + :op :method + :form form + :this this-expr + :name (symbol (name method)) + :children (into [:this] (:children method-expr))))) + +;; HACK +(defn -deftype [name class-name args interfaces] + + (doseq [arg [class-name name]] + (memo-clear! members* [arg]) + (memo-clear! members* [(str arg)])) + + (let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)] + (eval (list `let [] + (list 'deftype* name class-name args :implements interfaces) + (list `import class-name))))) + +(defn parse-reify* + [[_ interfaces & methods :as form] env] + (let [interfaces (conj (disj (set (mapv maybe-class interfaces)) Object) + IObj) + name (gensym "reify__") + class-name (symbol (str (namespace-munge *ns*) "$" name)) + menv (assoc env :this class-name) + methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) + methods)] + + (-deftype name class-name [] interfaces) + + (wrapping-meta + {:op :reify + :env env + :form form + :class-name class-name + :methods methods + :interfaces interfaces + :children [:methods]}))) + +(defn parse-opts+methods [methods] + (loop [opts {} methods methods] + (if (keyword? (first methods)) + (recur (assoc opts (first methods) (second methods)) (nnext methods)) + [opts methods]))) + +(defn parse-deftype* + [[_ name class-name fields _ interfaces & methods :as form] env] + (let [interfaces (disj (set (mapv maybe-class interfaces)) Object) + fields-expr (mapv (fn [name] + {:env env + :form name + :name name + :mutable (let [m (meta name)] + (or (and (:unsynchronized-mutable m) + :unsynchronized-mutable) + (and (:volatile-mutable m) + :volatile-mutable))) + :local :field + :op :binding}) + fields) + menv (assoc env + :context :ctx/expr + :locals (zipmap fields (map dissoc-env fields-expr)) + :this class-name) + [opts methods] (parse-opts+methods methods) + methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces) + methods)] + + (-deftype name class-name fields interfaces) + + {:op :deftype + :env env + :form form + :name name + :class-name class-name ;; internal, don't use as a Class + :fields fields-expr + :methods methods + :interfaces interfaces + :children [:fields :methods]})) + +(defn parse-case* + [[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env] + (let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map + e (ctx env :ctx/expr) + test-expr (-analyze expr e) + [tests thens] (reduce (fn [[te th] [min-hash [test then]]] + (let [test-expr (ana/analyze-const test e) + then-expr (-analyze then env)] + [(conj te {:op :case-test + :form test + :env e + :hash min-hash + :test test-expr + :children [:test]}) + (conj th {:op :case-then + :form then + :env env + :hash min-hash + :then then-expr + :children [:then]})])) + [[] []] case-map) + default-expr (-analyze default env)] + {:op :case + :form form + :env env + :test (assoc test-expr :case-test true) + :default default-expr + :tests tests + :thens thens + :shift shift + :mask mask + :low low + :high high + :switch-type switch-type + :test-type test-type + :skip-check? skip-check? + :children [:test :tests :thens :default]})) + +(defn parse + "Extension to tools.analyzer/-parse for JVM special forms" + [form env] + ((case (first form) + monitor-enter parse-monitor-enter + monitor-exit parse-monitor-exit + clojure.core/import* parse-import* + reify* parse-reify* + deftype* parse-deftype* + case* parse-case* + #_:else ana/-parse) + form env)) + +(def default-passes + "Set of passes that will be run by default on the AST by #'run-passes" + #{#'warn-on-reflection + #'warn-earmuff + + #'uniquify-locals + + #'source-info + #'elide-meta + #'constant-lift + + #'trim + + #'box + + #'analyze-host-expr + #'validate-loop-locals + #'validate + #'infer-tag + + #'classify-invoke}) + +(def scheduled-default-passes + (schedule default-passes)) + +(defn ^:dynamic run-passes + "Function that will be invoked on the AST tree immediately after it has been constructed, + by default runs the passes declared in #'default-passes, should be rebound if a different + set of passes is required. + + Use #'clojure.tools.analyzer.passes/schedule to get a function from a set of passes that + run-passes can be bound to." + [ast] + (scheduled-default-passes ast)) + +(def default-passes-opts + "Default :passes-opts for `analyze`" + {:collect/what #{:constants :callsites} + :collect/where #{:deftype :reify :fn} + :collect/top-level? false + :collect-closed-overs/where #{:deftype :reify :fn :loop :try} + :collect-closed-overs/top-level? false}) + +(defn analyze + "Analyzes a clojure form using tools.analyzer augmented with the JVM specific special ops + and returns its AST, after running #'run-passes on it. + + If no configuration option is provides, analyze will setup tools.analyzer using the extension + points declared in this namespace. + + If provided, opts should be a map of options to analyze, currently the only valid + options are :bindings and :passes-opts (if not provided, :passes-opts defaults to the + value of `default-passes-opts`). + If provided, :bindings should be a map of Var->value pairs that will be merged into the + default bindings for tools.analyzer, useful to provide custom extension points. + If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that + can be used to configure the behaviour of each pass. + + E.g. + (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}})" + ([form] (analyze form (empty-env) {})) + ([form env] (analyze form env {})) + ([form env opts] + (with-bindings (merge {Compiler/LOADER (RT/makeClassLoader) + #'ana/macroexpand-1 macroexpand-1 + #'ana/create-var create-var + #'ana/parse parse + #'ana/var? var? + #'elides (merge {:fn #{:line :column :end-line :end-column :file :source} + :reify #{:line :column :end-line :end-column :file :source}} + elides) + #'*ns* (the-ns (:ns env))} + (:bindings opts)) + (env/ensure (global-env) + (doto (env/with-env (mmerge (env/deref-env) + {:passes-opts (get opts :passes-opts default-passes-opts)}) + (run-passes (-analyze form env))) + (do (update-ns-map!))))))) + +(deftype ExceptionThrown [e ast]) + +(defn ^:private throw! [e] + (throw (.e ^ExceptionThrown e))) + +(defn analyze+eval + "Like analyze but evals the form after the analysis and attaches the + returned value in the :result field of the AST node. + + If evaluating the form will cause an exception to be thrown, the exception + will be caught and wrapped in an ExceptionThrown object, containing the + exception in the `e` field and the AST in the `ast` field. + + The ExceptionThrown object is then passed to `handle-evaluation-exception`, + which by defaults throws the original exception, but can be used to provide + a replacement return value for the evaluation of the AST. + + Unrolls `do` forms to handle the Gilardi scenario. + + Useful when analyzing whole files/namespaces." + ([form] (analyze+eval form (empty-env) {})) + ([form env] (analyze+eval form env {})) + ([form env {:keys [handle-evaluation-exception] + :or {handle-evaluation-exception throw!} + :as opts}] + (env/ensure (global-env) + (update-ns-map!) + (let [env (merge env (-source-info form env)) + [mform raw-forms] (with-bindings {Compiler/LOADER (RT/makeClassLoader) + #'*ns* (the-ns (:ns env)) + #'ana/macroexpand-1 (get-in opts [:bindings #'ana/macroexpand-1] macroexpand-1)} + (loop [form form raw-forms []] + (let [mform (ana/macroexpand-1 form env)] + (if (= mform form) + [mform (seq raw-forms)] + (recur mform (conj raw-forms + (if-let [[op & r] (and (seq? form) form)] + (if (or (u/macro? op env) + (u/inline? op r env)) + (vary-meta form assoc ::ana/resolved-op (resolve-sym op env)) + form) + form)))))))] + (if (and (seq? mform) (= 'do (first mform)) (next mform)) + ;; handle the Gilardi scenario + (let [[statements ret] (butlast+last (rest mform)) + statements-expr (mapv (fn [s] (analyze+eval s (-> env + (ctx :ctx/statement) + (assoc :ns (ns-name *ns*))) + opts)) + statements) + ret-expr (analyze+eval ret (assoc env :ns (ns-name *ns*)) opts)] + {:op :do + :top-level true + :form mform + :statements statements-expr + :ret ret-expr + :children [:statements :ret] + :env env + :result (:result ret-expr) + :raw-forms raw-forms}) + (let [a (analyze mform env opts) + frm (emit-form a) + result (try (eval frm) ;; eval the emitted form rather than directly the form to avoid double macroexpansion + (catch Exception e + (handle-evaluation-exception (ExceptionThrown. e a))))] + (merge a {:result result + :raw-forms raw-forms}))))))) + +(defn analyze-ns + "Analyzes a whole namespace, returns a vector of the ASTs for all the + top-level ASTs of that namespace. + Evaluates all the forms." + ([ns] (analyze-ns ns (empty-env))) + ([ns env] (analyze-ns ns env {})) + ([ns env opts] + (env/ensure (global-env) + (let [res ^URL (ns-url ns)] + (assert res (str "Can't find " ns " in classpath")) + (let [filename (str res) + path (.getPath res)] + (when-not (get-in (env/deref-env) [::analyzed-clj path]) + (binding [*ns* *ns* + *file* filename] + (with-open [rdr (io/reader res)] + (let [pbr (readers/indexing-push-back-reader + (java.io.PushbackReader. rdr) 1 filename) + eof (Object.) + read-opts {:eof eof :features #{:clj :t.a.jvm}} + read-opts (if (.endsWith filename "cljc") + (assoc read-opts :read-cond :allow) + read-opts)] + (loop [] + (let [form (reader/read read-opts pbr)] + (when-not (identical? form eof) + (swap! *env* update-in [::analyzed-clj path] + (fnil conj []) + (analyze+eval form (assoc env :ns (ns-name *ns*)) opts)) + (recur)))))))) + (get-in @*env* [::analyzed-clj path])))))) + +(defn macroexpand-all + "Like clojure.walk/macroexpand-all but correctly handles lexical scope" + ([form] (macroexpand-all form (empty-env) {})) + ([form env] (macroexpand-all form env {})) + ([form env opts] + (binding [run-passes emit-form] + (analyze form env opts)))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj b/src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj new file mode 100644 index 000000000..eb7ac83d8 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj @@ -0,0 +1,399 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.jvm.utils + (:require [clojure.tools.analyzer.utils :as u] + [clojure.tools.analyzer.env :as env] + [clojure.reflect :as reflect] + [clojure.string :as s] + [nextjournal.clerk.clojure.core.memoize :refer [lru]] + [clojure.java.io :as io]) + (:import (clojure.lang RT Symbol Var) + org.objectweb.asm.Type)) + +(set! *warn-on-reflection* true) + +(defn ^:private type-reflect + [typeref & options] + (apply reflect/type-reflect typeref + :reflector (reflect/->JavaReflector (RT/baseLoader)) + options)) + +(defn macro? [sym env] + (when-let [v (u/resolve-sym sym env)] + (and (not (-> env :locals (get sym))) + (u/macro? v) + v))) + +(defn inline? [sym args env] + (when-let [v (u/resolve-sym sym env)] + (let [inline-arities-f (:inline-arities (meta v))] + (and (not (-> env :locals (get sym))) + (or (not inline-arities-f) + (inline-arities-f (count args))) + (:inline (meta v)))))) + +(defn specials [c] + (case c + "byte" Byte/TYPE + "boolean" Boolean/TYPE + "char" Character/TYPE + "int" Integer/TYPE + "long" Long/TYPE + "float" Float/TYPE + "double" Double/TYPE + "short" Short/TYPE + "void" Void/TYPE + "object" Object + nil)) + +(defn special-arrays [c] + (case c + "bytes" (Class/forName "[B") + "booleans" (Class/forName "[Z") + "chars" (Class/forName "[C") + "ints" (Class/forName "[I") + "longs" (Class/forName "[J") + "floats" (Class/forName "[F") + "doubles" (Class/forName "[D") + "shorts" (Class/forName "[S") + "objects" (Class/forName "[Ljava.lang.Object;") + nil)) + +(defmulti ^Class maybe-class + "Takes a Symbol, String or Class and tires to resolve to a matching Class" + class) + +(defn array-class + ([element-type] (array-class 1 element-type)) + ([n element-type] + (RT/classForName + (str (apply str (repeat n"[")) + (-> element-type + maybe-class + Type/getType + .getDescriptor + (.replace \/ \.)))))) + +(defn maybe-class-from-string [^String s] + (or (when-let [maybe-class (and (neg? (.indexOf s ".")) + (not= \[ (first s)) + (if env/*env* + (u/resolve-sym (symbol s) {:ns (ns-name *ns*)}) + ((ns-map *ns*) (symbol s))))] + (when (class? maybe-class) maybe-class)) + (try (RT/classForName s) + (catch ClassNotFoundException _)))) + +(defmethod maybe-class :default [_] nil) +(defmethod maybe-class Class [c] c) +(defmethod maybe-class String [s] + (maybe-class (symbol s))) + +(defn maybe-array-class-sym [x] + (let [sname (name x)] + (if-let [c (and (= (count sname) 1) + (Character/isDigit (char (first sname))) + (namespace x))] + (when-let [c (or (specials c) + (maybe-class-from-string c))] + (array-class (Integer/parseInt sname) c))))) + +(defmethod maybe-class Symbol [sym] + (let [sname (name sym) + snamec (count sname)] + (or (maybe-array-class-sym sym) + (when-not (namespace sym) + (if-let [base-type (and (.endsWith sname "<>") + (maybe-class (subs sname 0 (- snamec 2))))] + ;; TODO: we're leaking into the syntax + (array-class base-type) + (if-let [ret (or (specials sname) + (special-arrays sname))] + ret + (maybe-class-from-string sname))))))) + +(defn maybe-class-literal [x] + (cond + (class? x) x + (symbol? x) (or (maybe-array-class-sym x) + (and (not (namespace x)) + (maybe-class-from-string (name x)))) + (string? x) (maybe-class-from-string x))) + +(def primitive? + "Returns non-nil if the argument represents a primitive Class other than Void" + #{Double/TYPE Character/TYPE Byte/TYPE Boolean/TYPE + Short/TYPE Float/TYPE Long/TYPE Integer/TYPE}) + +(def ^:private convertible-primitives + "If the argument is a primitive Class, returns a set of Classes + to which the primitive Class can be casted" + {Integer/TYPE #{Integer Long/TYPE Long Short/TYPE Byte/TYPE Object Number} + Float/TYPE #{Float Double/TYPE Object Number} + Double/TYPE #{Double Float/TYPE Object Number} + Long/TYPE #{Long Integer/TYPE Short/TYPE Byte/TYPE Object Number} + Character/TYPE #{Character Object} + Short/TYPE #{Short Object Number} + Byte/TYPE #{Byte Object Number} + Boolean/TYPE #{Boolean Object} + Void/TYPE #{Void}}) + +(defn ^Class box + "If the argument is a primitive Class, returns its boxed equivalent, + otherwise returns the argument" + [c] + ({Integer/TYPE Integer + Float/TYPE Float + Double/TYPE Double + Long/TYPE Long + Character/TYPE Character + Short/TYPE Short + Byte/TYPE Byte + Boolean/TYPE Boolean + Void/TYPE Void} + c c)) + +(defn ^Class unbox + "If the argument is a Class with a primitive equivalent, returns that, + otherwise returns the argument" + [c] + ({Integer Integer/TYPE, + Long Long/TYPE, + Float Float/TYPE, + Short Short/TYPE, + Boolean Boolean/TYPE, + Byte Byte/TYPE, + Character Character/TYPE, + Double Double/TYPE, + Void Void/TYPE} + c c)) + +(defn numeric? + "Returns true if the given class is numeric" + [c] + (when c + (.isAssignableFrom Number (box c)))) + +(defn subsumes? + "Returns true if c2 is subsumed by c1" + [c1 c2] + (let [c1 (maybe-class c1) + c2 (maybe-class c2)] + (and (not= c1 c2) + (or (and (not (primitive? c1)) + (primitive? c2)) + (.isAssignableFrom c2 c1))))) + +(defn convertible? + "Returns true if it's possible to convert from c1 to c2" + [c1 c2] + (let [c1 (maybe-class c1) + c2 (maybe-class c2)] + (if (nil? c1) + (not (primitive? c2)) + (or + (= c1 c2) + (.isAssignableFrom c2 c1) + (and (primitive? c2) + ((convertible-primitives c2) c1)) + (and (primitive? c1) + (.isAssignableFrom (box c1) c2)))))) + +(def wider-than + "If the argument is a numeric primitive Class, returns a set of primitive Classes + that are narrower than the given one" + {Long/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE} + Integer/TYPE #{Short/TYPE Byte/TYPE} + Float/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE} + Double/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE Float/TYPE} + Short/TYPE #{Byte/TYPE} + Byte/TYPE #{}}) + +(defn wider-primitive + "Given two numeric primitive Classes, returns the wider one" + [from to] + (if ((wider-than from) to) + from + to)) + +(defn wider-tag* + "Given two Classes returns the wider one" + [from to] + (if (not= from to) + (if (primitive? from) + (if (primitive? to) + (wider-primitive from to) + (or (and (numeric? from) + (numeric? to) + to) + ((convertible-primitives from) to))) + (if (primitive? to) + (or (and (numeric? from) + (numeric? to) + from) + ((convertible-primitives to) from)) + (if (convertible? from to) + to + (when (convertible? to from) + from)))) + from)) + +(defn wider-tag + "Given a collection of Classes returns the wider one" + [tags] + (let [tags* (filter identity tags) + wider (loop [wider (first tags*) tags* (rest tags*)] + (if (seq tags*) + (if-let [t (wider-tag* wider (first tags*))] + (recur t (rest tags*))) + wider))] + (when (or (= tags* tags) + (not (primitive? wider))) + wider))) + +(defn name-matches? + [member] + (let [member-name (str member) + i (.lastIndexOf member-name ".") + member-name* (when (pos? i) + (str (s/replace (subs member-name 0 i) "-" "_") (subs member-name i))) + member-name** (s/replace member-name "-" "_") + member-name*** (munge member-name)] + (fn [name] + (let [name (str name)] + (or (= member-name name) + (= member-name* name) + (= member-name** name) + (= member-name*** name)))))) + +(def object-members + (:members (type-reflect Object))) + +(def members* + (lru (fn members* + ([class] + (into object-members + (remove (fn [{:keys [flags]}] + (not-any? #{:public :protected} flags)) + (-> class + maybe-class + ^Class (box) + .getName + symbol + (type-reflect :ancestors true) + :members))))))) + +(defn members + ([class] (members* class)) + ([class member] + (when-let [members (filter #((name-matches? member) (:name %)) + (members* class))] + members))) + +(defn static-members [class f] + (when-let [members (members class f)] + (when-let [statics (filter (comp :static :flags) members)] + statics))) + +(defn instance-members [class f] + (when-let [members (members class f)] + (when-let [i-members (remove (comp :static :flags) members)] + i-members))) + +(defn static-methods [class method argc] + (filter #(= argc (count (:parameter-types %))) + (filter :return-type (static-members class method)))) + +(defn instance-methods [class method argc] + (filter #(= argc (count (:parameter-types %))) + (filter :return-type (instance-members class method)))) + +(defn static-field [class f] + (when-let [statics (static-members class f)] + (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) + (comp nil? :return-type)) + statics)] + member))) + +(defn instance-field [class f] + (when-let [i-members (instance-members class f)] + (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types) + (comp nil? :return-type)) + i-members)] + member))) + +(defn static-method [class method] + (first (static-methods class method 0))) + +(defn instance-method [class method] + (first (instance-methods class method 0))) + +(defn prim-or-obj + "If the given Class is a primitive, returns that Class, otherwise returns Object" + [tag] + (if (and tag (primitive? tag)) + tag + java.lang.Object)) + +(defn prim-interface [tags] + (when (some primitive? tags) + (let [sig (apply str (mapv #(.toUpperCase (subs (.getSimpleName ^Class %) 0 1)) tags))] + (maybe-class (str "clojure.lang.IFn$" sig))))) + +(defn tag-match? [arg-tags meth] + (every? identity (map convertible? arg-tags (:parameter-types meth)))) + +(defn try-best-match + "Given a vector of arg tags and a collection of methods, tries to return the + subset of methods that match best the given tags" + [tags methods] + (let [o-tags (mapv #(or (maybe-class %) Object) tags)] + (if-let [methods (or (seq (filter + #(= o-tags (mapv maybe-class (:parameter-types %))) methods)) + (seq (filter #(tag-match? tags %) methods)))] + (reduce (fn [[prev & _ :as p] next] + (let [prev-params (mapv maybe-class (:parameter-types prev)) + next-params (mapv maybe-class (:parameter-types next)) + prev-ret (maybe-class (:return-type prev)) + next-ret (maybe-class (:return-type next)) + prev-decl (maybe-class (:declaring-class prev)) + next-decl (maybe-class (:declaring-class next))] + (cond + (not prev) + [next] + (= prev-params next-params) + (cond + (= prev-ret next-ret) + (cond + (.isAssignableFrom prev-decl next-decl) + [next] + (.isAssignableFrom next-decl prev-decl) + p + :else + (conj p next)) + (.isAssignableFrom prev-ret next-ret) + [next] + (.isAssignableFrom next-ret prev-ret) + p + :else + (conj p next)) + (and (some true? (map subsumes? next-params prev-params)) + (not-any? true? (map subsumes? prev-params next-params))) + [next] + :else + (conj p next)))) [] methods) + methods))) + +(defn ns->relpath [s] + (-> s str (s/replace \. \/) (s/replace \- \_) (str ".clj"))) + +(defn ns-url [ns] + (let [f (ns->relpath ns)] + (or (io/resource f) + (io/resource (str f "c"))))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj new file mode 100644 index 000000000..ccd982115 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj @@ -0,0 +1,198 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.analyze-host-expr + (:require [clojure.tools.analyzer :as ana] + [clojure.tools.analyzer.utils :refer [ctx source-info merge']] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer :all])) + +(defn maybe-static-field [[_ class sym]] + (when-let [{:keys [flags type name]} (static-field class sym)] + {:op :static-field + :assignable? (not (:final flags)) + :class class + :field name + :o-tag type + :tag type})) + +(defn maybe-static-method [[_ class sym]] + (when-let [{:keys [name return-type]} (static-method class sym)] + {:op :static-call + :tag return-type + :o-tag return-type + :class class + :method name})) + +(defn maybe-instance-method [target-expr class sym] + (when-let [{:keys [return-type]} (instance-method class sym)] + {:op :instance-call + :tag return-type + :o-tag return-type + :instance target-expr + :class class + :method sym + :children [:instance]})) + +(defn maybe-instance-field [target-expr class sym] + (when-let [{:keys [flags name type]} (instance-field class sym)] + {:op :instance-field + :assignable? (not (:final flags)) + :class class + :instance target-expr + :field name + :tag type + :o-tag type + :children [:instance]})) + +(defn analyze-host-call + [target-type method args target-expr class env] + (let [op (case target-type + :static :static-call + :instance :instance-call)] + (merge + {:op op + :method method + :args args} + (case target-type + :static {:class class + :children [:args]} + :instance {:instance target-expr + :class (maybe-class (:tag target-expr)) + :children [:instance :args]})))) + +(defn analyze-host-field + [target-type field target-expr class env] + (if class + (case target-type + :static (or (maybe-static-field (list '. class field)) + (throw (ex-info (str "Cannot find field " + field " for class " class) + (merge {:class class + :field field} + (source-info env))))) + :instance (or (maybe-instance-field target-expr class field) + {:op :host-interop + :target (dissoc target-expr :tag :validated?) + :m-or-f field + :assignable? true + :children [:target]} + (when (:literal? target-expr) + (throw (ex-info (str "Cannot find field " + field " for class " class) + (merge {:instance (dissoc target-expr :env) + :field field} + (source-info env))))))) + {:op :host-interop + :target target-expr + :m-or-f field + :assignable? true + :children [:target]})) + +(defn -analyze-host-expr + [target-type m-or-f target-expr class env] + (let [target-class (-> target-expr :tag) + [field method] (if class + [(maybe-static-field (list '. class m-or-f)) + (maybe-static-method (list '. class m-or-f))] + (when target-class + [(maybe-instance-field target-expr target-class m-or-f) + (maybe-instance-method target-expr target-class m-or-f)]))] + (cond + + (not (or class target-class)) + {:op :host-interop + :target target-expr + :m-or-f m-or-f + :assignable? true + :children [:target]} + + method + method + + field + field + + class + (throw (ex-info (str "Cannot find field or no-arg method call " + m-or-f " for class " class) + (merge {:class class + :m-or-f m-or-f} + (source-info env)))) + + target-class + {:op :host-interop + :target (dissoc target-expr :tag :validated?) + :m-or-f m-or-f + :assignable? true + :children [:target]} + + :else + (when (:literal? target-expr) + (throw (ex-info (str "Cannot find field or no-arg method call " + m-or-f " for class " target-class) + (merge {:instance (dissoc target-expr :env) + :m-or-f m-or-f} + (source-info env)))))))) + +(defn analyze-host-expr + "Performing some reflection, transforms :host-interop/:host-call/:host-field + nodes in either: :static-field, :static-call, :instance-call, :instance-field + or :host-interop nodes, and a :var/:maybe-class/:maybe-host-form node in a + :const :class node, if necessary (class literals shadow Vars). + + A :host-interop node represents either an instance-field or a no-arg instance-method. " + {:pass-info {:walk :post :depends #{}}} + [{:keys [op target form tag env class] :as ast}] + (case op + (:host-interop :host-call :host-field) + (let [target (if-let [the-class (and (= :local (:op target)) + (maybe-class-literal (:form target)))] + (merge target + (assoc (ana/analyze-const the-class env :class) + :tag Class + :o-tag Class)) + target) + class? (and (= :const (:op target)) + (= :class (:type target)) + (:form target)) + target-type (if class? :static :instance)] + (merge' (dissoc ast :assignable? :target :args :children) + (case op + + :host-call + (analyze-host-call target-type (:method ast) + (:args ast) target class? env) + + :host-field + (analyze-host-field target-type (:field ast) + target (or class? (:tag target)) env) + + :host-interop + (-analyze-host-expr target-type (:m-or-f ast) + target class? env)) + (when tag + {:tag tag}))) + :var + (if-let [the-class (and (not (namespace form)) + (pos? (.indexOf (str form) ".")) + (maybe-class-literal form))] + (assoc (ana/analyze-const the-class env :class) :form form) + ast) + + :maybe-class + (if-let [the-class (maybe-class-literal class)] + (assoc (ana/analyze-const the-class env :class) :form form) + ast) + + :maybe-host-form + (if-let [the-class (maybe-array-class-sym (symbol (str (:class ast)) + (str (:field ast))))] + (assoc (ana/analyze-const the-class env :class) :form form) + ast) + + ast)) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj new file mode 100644 index 000000000..1514710b0 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj @@ -0,0 +1,46 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-branch) + +(defmulti annotate-branch + "Adds :branch? to branch AST nodes (if/case), :test? to the test children + node of the branching op and :path? to the branching paths. + + Example: {:op if :branch? true :test {:test? true ..} :then {:path? true ..} ..}" + {:pass-info {:walk :any :depends #{}}} + :op) + +(defmethod annotate-branch :if + [ast] + (-> ast + (assoc :branch? true) + (assoc-in [:test :test?] true) + (assoc-in [:then :path?] true) + (assoc-in [:else :path?] true))) + +(defmethod annotate-branch :fn-method + [ast] + (assoc ast :path? true)) + +(defmethod annotate-branch :method + [ast] + (assoc ast :path? true)) + +(defmethod annotate-branch :case + [ast] + (-> ast + (assoc :branch? true) + (assoc-in [:test :test?] true) + (assoc-in [:default :path?] true))) + +(defmethod annotate-branch :case-then + [ast] + (assoc ast :path? true)) + +(defmethod annotate-branch :default [ast] ast) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj new file mode 100644 index 000000000..1aa145a07 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj @@ -0,0 +1,109 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-host-info + (:require [clojure.tools.analyzer :as ana] + [clojure.tools.analyzer.ast :refer [prewalk]] + [clojure.tools.analyzer.passes + [cleanup :refer [cleanup]] + [elide-meta :refer [elide-meta]]] + [clojure.tools.analyzer.utils :refer [source-info]] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils + :refer [members name-matches? try-best-match] + :as u])) + +(defn annotate-host-info + "Adds a :methods key to reify/deftype :methods info representing + the reflected informations for the required methods, replaces + (catch :default ..) forms with (catch Throwable ..)" + {:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}} + [{:keys [op methods interfaces class env] :as ast}] + (case op + (:reify :deftype) + (let [all-methods + (into #{} + (mapcat (fn [class] + (mapv (fn [method] + (dissoc method :exception-types)) + (filter (fn [{:keys [flags return-type]}] + (and return-type (not-any? #{:final :static} flags))) + (members class)))) + (conj interfaces Object)))] + (assoc ast :methods (mapv (fn [ast] + (let [name (:name ast) + argc (count (:params ast))] + (assoc ast :methods + (filter #(and ((name-matches? name) (:name %)) + (= argc (count (:parameter-types %)))) + all-methods)))) methods))) + + + :catch + (let [the-class (cond + + (and (= :const (:op class)) + (= :default (:form class))) + Throwable + + (= :maybe-class (:op class)) + (u/maybe-class-literal (:class class))) + + ast (if the-class + (-> ast + (assoc :class (assoc (ana/analyze-const the-class env :class) + :form (:form class) + :tag Class + :o-tag Class))) + ast)] + (assoc-in ast [:local :tag] (-> ast :class :val))) + + + :method + ;; this should actually be in validate but it's here since it needs to be prewalked + ;; for infer-tag purposes + (let [{:keys [name class tag form params fixed-arity env]} ast] + (if interfaces + (let [tags (mapv (comp u/maybe-class :tag meta :form) params) + methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods))] + (let [[m & rest :as matches] (try-best-match tags methods)] + (if m + (let [ret-tag (u/maybe-class (:return-type m)) + i-tag (u/maybe-class (:declaring-class m)) + arg-tags (mapv u/maybe-class (:parameter-types m)) + params (mapv (fn [{:keys [atom] :as arg} tag] + (assoc arg :tag tag :o-tag tag)) params arg-tags)] + (if (or (empty? rest) + (every? (fn [{:keys [return-type parameter-types]}] + (and (= (u/maybe-class return-type) ret-tag) + (= arg-tags (mapv u/maybe-class parameter-types)))) rest)) + (assoc (dissoc ast :interfaces :methods) + :bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %))) + (.isAssignableFrom (u/maybe-class (:return-type %)) ret-tag)) + (disj methods-set (dissoc m :declaring-class :flags))) + :methods methods + :interface i-tag + :tag ret-tag + :o-tag ret-tag + :params params) + (throw (ex-info (str "Ambiguous method signature for method: " name) + (merge {:method name + :interfaces interfaces + :form form + :params (mapv (fn [x] (prewalk x cleanup)) params) + :matches matches} + (source-info env)))))) + (throw (ex-info (str "No such method found: " name " with given signature in any of the" + " provided interfaces: " interfaces) + (merge {:method name + :methods methods + :interfaces interfaces + :form form + :params params} + (source-info env))))))) + ast)) + ast)) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj new file mode 100644 index 000000000..264c5e750 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj @@ -0,0 +1,132 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-loops + (:require [clojure.tools.analyzer.ast :refer [update-children]])) + +(defmulti annotate-loops + "Adds a :loops field to nodes that represent a code path that + might be visited more than once because of a recur. + + The field is a set of loop-ids representing the loops that might + recur into that path + + Note that because (recur expr) is equivalent to (let [e expr] (recur e)) + the node corresponting to expr will have the same :loops field + as the nodes in the same code path of the recur" + {:pass-info {:walk :pre :depends #{}}} + :op) + +(defmulti check-recur :op) + +(defn -check-recur [ast k] + (let [ast (update-in ast [k] check-recur)] + (if (:recurs (k ast)) + (assoc ast :recurs true) + ast))) + +(defmethod check-recur :do + [ast] + (let [ast (-check-recur ast :ret)] + (if (:recurs ast) + (assoc ast :statements (mapv (fn [s] (assoc s :recurs true)) (:statements ast))) + ast))) + +(defmethod check-recur :let + [ast] + (-check-recur ast :body)) + +(defmethod check-recur :letfn + [ast] + (-check-recur ast :body)) + +(defmethod check-recur :if + [ast] + (-> ast + (-check-recur :then) + (-check-recur :else))) + +(defmethod check-recur :case + [ast] + (let [ast (-> ast + (-check-recur :default) + (update-in [:thens] #(mapv check-recur %)))] + (if (some :recurs (:thens ast)) + (assoc ast :recurs true) + ast))) + +(defmethod check-recur :case-then + [ast] + (-check-recur ast :then)) + +(defmethod check-recur :recur + [ast] + (assoc ast :recurs true)) + +(defmethod check-recur :default + [ast] + ast) + +(defn -loops [ast loop-id] + (update-in ast [:loops] (fnil conj #{}) loop-id)) + +(defmethod annotate-loops :loop + [{:keys [loops loop-id] :as ast}] + (let [ast (if loops + (update-children ast #(assoc % :loops loops)) + ast) + ast (update-in ast [:body] check-recur)] + (if (-> ast :body :recurs) + (update-in ast [:body] -loops loop-id) + ast))) + +(defmethod annotate-loops :default + [{:keys [loops] :as ast}] + (if loops + (update-children ast #(assoc % :loops loops)) + ast)) + +(defmethod annotate-loops :if + [{:keys [loops test then else env] :as ast}] + (if loops + (let [loop-id (:loop-id env) + loops-no-recur (disj loops loop-id) + branch-recurs? (or (:recurs then) (:recurs else)) + then (if (or (:recurs then) ;; the recur is inside the then branch + ;; the recur is in the same code path of the if expression + (not branch-recurs?)) + (assoc then :loops loops) + (assoc then :loops loops-no-recur)) + else (if (or (:recurs else) (not branch-recurs?)) + (assoc else :loops loops) + (assoc else :loops loops-no-recur))] + (assoc ast + :then then + :else else + :test (assoc test :loops loops))) + ast)) + +(defmethod annotate-loops :case + [{:keys [loops test default thens env] :as ast}] + (if loops + (let [loop-id (:loop-id env) + loops-no-recur (disj loops loop-id) + branch-recurs? (some :recurs (conj thens default)) + + default (if (or (:recurs default) (not branch-recurs?)) + (assoc default :loops loops) + (assoc default :loops loops-no-recur)) + + thens (mapv #(if (or (:recurs %) (not branch-recurs?)) + (assoc % :loops loops) + (assoc % :loops loops-no-recur)) thens)] + (assoc ast + :thens thens + :default default + :test (assoc test :loops loops))) + ast)) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj new file mode 100644 index 000000000..92e23f593 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj @@ -0,0 +1,96 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-tag + (:require [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer [unbox maybe-class]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.constant-lifter :refer [constant-lift]]) + (:import (clojure.lang ISeq Var AFunction))) + +(defmulti -annotate-tag :op) + +(defmethod -annotate-tag :default [ast] ast) + +(defmethod -annotate-tag :map + [{:keys [val form] :as ast}] + (let [t (class (or val form))] + (assoc ast :o-tag t :tag t))) + +(defmethod -annotate-tag :set + [{:keys [val form] :as ast}] + (let [t (class (or val form))] + (assoc ast :o-tag t :tag t))) + +(defmethod -annotate-tag :vector + [{:keys [val form] :as ast}] + (let [t (class (or val form))] + (assoc ast :o-tag t :tag t))) + +(defmethod -annotate-tag :the-var + [ast] + (assoc ast :o-tag Var :tag Var)) + +(defmethod -annotate-tag :const + [ast] + (case (:type ast) + + ;; char and numbers are unboxed by default + :number + (let [t (unbox (class (:val ast)))] + (assoc ast :o-tag t :tag t)) + + :char + (assoc ast :o-tag Character/TYPE :tag Character/TYPE) + + :seq + (assoc ast :o-tag ISeq :tag ISeq) + + (let [t (class (:val ast))] + (assoc ast :o-tag t :tag t)))) + +(defmethod -annotate-tag :binding + [{:keys [form tag atom o-tag init local name variadic?] :as ast}] + (let [o-tag (or (:tag init) ;; should defer to infer-tag? + (and (= :fn local) AFunction) + (and (= :arg local) variadic? ISeq) + o-tag + Object) + o-tag (if (#{Void Void/TYPE} o-tag) + Object + o-tag)] + (if-let [tag (or (:tag (meta form)) tag)] + (let [ast (assoc ast :tag tag :o-tag tag)] + (if init + (assoc-in ast [:init :tag] (maybe-class tag)) + ast)) + (assoc ast :tag o-tag :o-tag o-tag)))) + +(defmethod -annotate-tag :local + [{:keys [name form tag atom case-test] :as ast}] + (let [o-tag (@atom :tag)] + (assoc ast :o-tag o-tag :tag o-tag))) + +;; TODO: move binding/local logic to infer-tag +(defn annotate-tag + "If the AST node type is a constant object or contains :tag metadata, + attach the appropriate :tag and :o-tag to the node." + {:pass-info {:walk :post :depends #{} :after #{#'constant-lift}}} + [{:keys [op tag o-tag atom] :as ast}] + (let [ast (if (and atom (:case-test @atom)) + (update-in ast [:form] vary-meta dissoc :tag) + ast) + ast + (if (and o-tag tag) + ast + (if-let [tag (or tag + (-> ast :val meta :tag) + (-> ast :form meta :tag))] + (assoc (-annotate-tag ast) :tag tag) + (-annotate-tag ast)))] + (when (= op :binding) + (swap! atom assoc :tag (:tag ast))) + ast)) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj new file mode 100644 index 000000000..a7096e29f --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj @@ -0,0 +1,200 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.box + (:require [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u] + [clojure.tools.analyzer.utils :refer [protocol-node? arglist-for-arity]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [validate :refer [validate]] + [infer-tag :refer [infer-tag]]])) + +(defmulti box + "Box the AST node tag where necessary" + {:pass-info {:walk :pre :depends #{#'infer-tag} :after #{#'validate}}} + :op) + +(defmacro if-let-box [class then else] + `(let [c# ~class + ~class (u/box c#)] + (if (u/primitive? c#) + ~then + ~else))) + +(defn -box [ast] + (let [tag (:tag ast)] + (if (u/primitive? tag) + (assoc ast :tag (u/box tag)) + ast))) + +(defn boxed? [tag expr] + (and (or (nil? tag) (not (u/primitive? tag))) + (u/primitive? (:tag expr)))) + +(defmethod box :instance-call + [{:keys [args class validated? tag] :as ast}] + (let [ast (if-let-box class + (assoc (update-in ast [:instance :tag] u/box) :class class) + ast)] + (if validated? + ast + (assoc ast :args (mapv -box args) + :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) + tag + Object))))) + +(defmethod box :static-call + [{:keys [args validated? tag] :as ast}] + (if validated? + ast + (assoc ast :args (mapv -box args) + :o-tag Object :tag (if (not (#{Void Void/TYPE} tag)) + tag + Object)))) + +(defmethod box :new + [{:keys [args validated?] :as ast}] + (if validated? + ast + (assoc ast :args (mapv -box args) + :o-tag Object))) + +(defmethod box :instance-field + [{:keys [class] :as ast}] + (if-let-box class + (assoc (update-in ast [:instance :tag] u/box) :class class) + ast)) + +(defmethod box :def + [{:keys [init] :as ast}] + (if (and init (u/primitive? (:tag init))) + (update-in ast [:init] -box) + ast)) + +(defmethod box :vector + [ast] + (assoc ast :items (mapv -box (:items ast)))) + +(defmethod box :set + [ast] + (assoc ast :items (mapv -box (:items ast)))) + +(defmethod box :map + [ast] + (let [keys (mapv -box (:keys ast)) + vals (mapv -box (:vals ast))] + (assoc ast + :keys keys + :vals vals))) + +(defmethod box :do + [ast] + (if (boxed? (:tag ast) (:ret ast)) + (-> ast + (update-in [:ret] -box) + (update-in [:o-tag] u/box)) + ast)) + +(defmethod box :quote + [ast] + (if (boxed? (:tag ast) (:ret ast)) + (-> ast + (update-in [:expr] -box) + (update-in [:o-tag] u/box)) + ast)) + +(defmethod box :protocol-invoke + [ast] + (assoc ast :args (mapv -box (:args ast)))) + +(defmethod box :let + [{:keys [tag body] :as ast}] + (if (boxed? tag body) + (-> ast + (update-in [:body] -box) + (update-in [:o-tag] u/box)) + ast)) + +(defmethod box :letfn + [ast] + (if (boxed? (:tag ast) (:body ast)) + (-> ast + (update-in [:body] -box) + (update-in [:o-tag] u/box)) + ast)) + +(defmethod box :loop + [ast] + (if (boxed? (:tag ast) (:body ast)) + (-> ast + (update-in [:body] -box) + (update-in [:o-tag] u/box)) + ast)) + +(defmethod box :fn-method + [{:keys [params tag] :as ast}] + (let [ast (if (u/primitive? tag) + ast + (-> ast + (update-in [:body] -box) + (update-in [:o-tag] u/box)))] + (assoc ast + :params (mapv (fn [{:keys [o-tag] :as p}] + (assoc p :o-tag (u/prim-or-obj o-tag))) params) + :tag (u/prim-or-obj tag) + :o-tag (u/prim-or-obj tag)))) + +(defmethod box :if + [{:keys [test then else tag o-tag] :as ast}] + (let [test-tag (:tag test) + test (if (and (u/primitive? test-tag) + (not= Boolean/TYPE test-tag)) + (assoc test :tag (u/box test-tag)) + test) + [then else o-tag] (if (or (boxed? tag then) + (boxed? tag else) + (not o-tag)) + (conj (mapv -box [then else]) (u/box o-tag)) + [then else o-tag])] + (merge ast + {:test test + :o-tag o-tag + :then then + :else else}))) + +(defmethod box :case + [{:keys [tag default tests thens test-type] :as ast}] + (let [ast (if (and tag (u/primitive? tag)) + ast + (-> ast + (assoc-in [:thens] (mapv (fn [t] (update-in t [:then] -box)) thens)) + (update-in [:default] -box) + (update-in [:o-tag] u/box)))] + (if (= :hash-equiv test-type) + (-> ast + (update-in [:test] -box) + (assoc-in [:tests] (mapv (fn [t] (update-in t [:test] -box)) tests))) + ast))) + +(defmethod box :try + [{:keys [tag] :as ast}] + (let [ast (if (and tag (u/primitive? tag)) + ast + (-> ast + (update-in [:catches] #(mapv -box %)) + (update-in [:body] -box) + (update-in [:o-tag] u/box)))] + (-> ast + (update-in [:finally] -box)))) + +(defmethod box :invoke + [ast] + (assoc ast + :args (mapv -box (:args ast)) + :o-tag Object)) + +(defmethod box :default [ast] ast) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj new file mode 100644 index 000000000..ad3da1695 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj @@ -0,0 +1,91 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.classify-invoke + (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity protocol-node? source-info]] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils + :refer [specials prim-interface]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate :refer [validate]])) + +(defn classify-invoke + "If the AST node is an :invoke, check the node in function position, + * if it is a keyword, transform the node in a :keyword-invoke node; + * if it is the clojure.core/instance? var and the first argument is a + literal class, transform the node in a :instance? node to be inlined by + the emitter + * if it is a protocol function var, transform the node in a :protocol-invoke + node + * if it is a regular function with primitive type hints that match a + clojure.lang.IFn$[primitive interface], transform the node in a :prim-invoke + node" + {:pass-info {:walk :post :depends #{#'validate}}} + [{:keys [op args tag env form] :as ast}] + (if-not (= op :invoke) + ast + (let [argc (count args) + the-fn (:fn ast) + op (:op the-fn) + var? (= :var op) + the-var (:var the-fn)] + + (cond + + (and (= :const op) + (= :keyword (:type the-fn))) + (if (<= 1 argc 2) + (if (and (not (namespace (:val the-fn))) + (= 1 argc)) + (merge (dissoc ast :fn :args) + {:op :keyword-invoke + :target (first args) + :keyword the-fn + :children [:keyword :target]}) + ast) + (throw (ex-info (str "Cannot invoke keyword with " argc " arguments") + (merge {:form form} + (source-info env))))) + (and (= 2 argc) + var? + (= #'clojure.core/instance? the-var) + (= :const (:op (first args))) + (= :class (:type (first args)))) + (merge (dissoc ast :fn :args) + {:op :instance? + :class (:val (first args)) + :target (second args) + :form form + :env env + :o-tag Boolean/TYPE + :tag (or tag Boolean/TYPE) + :children [:target]}) + + (and var? (protocol-node? the-var (:meta the-fn))) + (if (>= argc 1) + (merge (dissoc ast :fn) + {:op :protocol-invoke + :protocol-fn the-fn + :target (first args) + :args (vec (rest args)) + :children [:protocol-fn :target :args]}) + (throw (ex-info "Cannot invoke protocol method with no args" + (merge {:form form} + (source-info env))))) + + :else + (let [arglist (arglist-for-arity the-fn argc) + arg-tags (mapv (comp specials str :tag meta) arglist) + ret-tag (-> arglist meta :tag str specials) + tags (conj arg-tags ret-tag)] + (if-let [prim-interface (prim-interface (mapv #(if (nil? %) Object %) tags))] + (merge ast + {:op :prim-invoke + :prim-interface prim-interface + :args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) + :o-tag ret-tag + :tag (or tag ret-tag)}) + ast)))))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj new file mode 100644 index 000000000..f9b35c632 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj @@ -0,0 +1,26 @@ +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.constant-lifter + (:require [clojure.tools.analyzer.passes.constant-lifter :as orig] + [clojure.tools.analyzer :refer [analyze-const]] + [clojure.tools.analyzer.utils :refer [constant? classify]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.analyze-host-expr :refer [analyze-host-expr]] + [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]])) + +(defn constant-lift* + [ast] + (if (= :var (:op ast)) + (let [{:keys [var env form meta]} ast] + (if (constant? var meta) + (let [val @var] + (assoc (analyze-const val env (classify val)) + :form form)) + ast)) + (orig/constant-lift ast))) + +(defn constant-lift + "Like clojure.tools.analyzer.passes.constant-lifter/constant-lift but + transforms also :var nodes where the var has :const in the metadata + into :const nodes and preserves tag info" + {:pass-info {:walk :post :depends #{} :after #{#'elide-meta #'analyze-host-expr}}} + [ast] + (merge (constant-lift* ast) + (select-keys ast [:tag :o-tag :return-tag :arglists]))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj new file mode 100644 index 000000000..7246fca13 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj @@ -0,0 +1,169 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.emit-form + (:require [clojure.tools.analyzer.passes + [emit-form :as default] + [uniquify :refer [uniquify-locals]]])) + +(defmulti -emit-form (fn [{:keys [op]} _] op)) + +(defn -emit-form* + [{:keys [form] :as ast} opts] + (let [expr (-emit-form ast opts)] + (if-let [m (and (instance? clojure.lang.IObj expr) + (meta form))] + (with-meta expr (merge m (meta expr))) + expr))) + +;; TODO: use pass opts infr +(defn emit-form + "Return the form represented by the given AST + Opts is a set of options, valid options are: + * :hygienic + * :qualified-vars (DEPRECATED, use :qualified-symbols instead) + * :qualified-symbols" + {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} + ([ast] (emit-form ast #{})) + ([ast opts] + (binding [default/-emit-form* -emit-form*] + (-emit-form* ast opts)))) + +(defn emit-hygienic-form + "Return an hygienic form represented by the given AST" + {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}} + [ast] + (binding [default/-emit-form* -emit-form*] + (-emit-form* ast #{:hygienic}))) + +(defmethod -emit-form :default + [ast opts] + (default/-emit-form ast opts)) + +(defmethod -emit-form :const + [{:keys [type val] :as ast} opts] + (if (and (= type :class) + (:qualified-symbols opts)) + (symbol (.getName ^Class val)) + (default/-emit-form ast opts))) + +(defmethod -emit-form :monitor-enter + [{:keys [target]} opts] + `(monitor-enter ~(-emit-form* target opts))) + +(defmethod -emit-form :monitor-exit + [{:keys [target]} opts] + `(monitor-exit ~(-emit-form* target opts))) + +(defmethod -emit-form :import + [{:keys [class]} opts] + `(clojure.core/import* ~class)) + +(defmethod -emit-form :the-var + [{:keys [^clojure.lang.Var var]} opts] + `(var ~(symbol (name (ns-name (.ns var))) (name (.sym var))))) + +(defmethod -emit-form :method + [{:keys [params body this name form]} opts] + (let [params (into [this] params)] + `(~(with-meta name (meta (first form))) + ~(with-meta (mapv #(-emit-form* % opts) params) + (meta (second form))) + ~(-emit-form* body opts)))) + +(defn class->str [class] + (if (symbol? class) + (name class) + (.getName ^Class class))) + +(defn class->sym [class] + (if (symbol? class) + class + (symbol (.getName ^Class class)))) + +(defmethod -emit-form :catch + [{:keys [class local body]} opts] + `(catch ~(-emit-form* class opts) ~(-emit-form* local opts) + ~(-emit-form* body opts))) + +(defmethod -emit-form :deftype + [{:keys [name class-name fields interfaces methods]} opts] + `(deftype* ~name ~(class->sym class-name) ~(mapv #(-emit-form* % opts) fields) + :implements ~(mapv class->sym interfaces) + ~@(mapv #(-emit-form* % opts) methods))) + +(defmethod -emit-form :reify + [{:keys [interfaces methods]} opts] + `(reify* ~(mapv class->sym (disj interfaces clojure.lang.IObj)) + ~@(mapv #(-emit-form* % opts) methods))) + +(defmethod -emit-form :case + [{:keys [test default tests thens shift mask low high switch-type test-type skip-check?]} opts] + `(case* ~(-emit-form* test opts) + ~shift ~mask + ~(-emit-form* default opts) + ~(apply sorted-map + (mapcat (fn [{:keys [hash test]} {:keys [then]}] + [hash [(-emit-form* test opts) (-emit-form* then opts)]]) + tests thens)) + ~switch-type ~test-type ~skip-check?)) + +(defmethod -emit-form :static-field + [{:keys [class field]} opts] + (symbol (class->str class) (name field))) + +(defmethod -emit-form :static-call + [{:keys [class method args]} opts] + `(~(symbol (class->str class) (name method)) + ~@(mapv #(-emit-form* % opts) args))) + +(defmethod -emit-form :instance-field + [{:keys [instance field]} opts] + `(~(symbol (str ".-" (name field))) ~(-emit-form* instance opts))) + +(defmethod -emit-form :instance-call + [{:keys [instance method args]} opts] + `(~(symbol (str "." (name method))) ~(-emit-form* instance opts) + ~@(mapv #(-emit-form* % opts) args))) + +(defmethod -emit-form :prim-invoke + [{:keys [fn args]} opts] + `(~(-emit-form* fn opts) + ~@(mapv #(-emit-form* % opts) args))) + +(defmethod -emit-form :protocol-invoke + [{:keys [protocol-fn target args]} opts] + `(~(-emit-form* protocol-fn opts) + ~(-emit-form* target opts) + ~@(mapv #(-emit-form* % opts) args))) + +(defmethod -emit-form :keyword-invoke + [{:keys [target keyword]} opts] + (list (-emit-form* keyword opts) + (-emit-form* target opts))) + +(defmethod -emit-form :instance? + [{:keys [class target]} opts] + `(instance? ~class ~(-emit-form* target opts))) + +(defmethod -emit-form :var + [{:keys [form ^clojure.lang.Var var]} opts] + (if (or (:qualified-symbols opts) + (:qualified-vars opts)) + (with-meta (symbol (-> var .ns ns-name name) (-> var .sym name)) + (meta form)) + form)) + +(defmethod -emit-form :def + [ast opts] + (let [f (default/-emit-form ast opts)] + (if (:qualified-symbols opts) + `(def ~(with-meta (symbol (-> ast :env :ns name) (str (second f))) + (meta (second f))) + ~@(nthrest f 2)) + f))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj new file mode 100644 index 000000000..b21d08a7f --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj @@ -0,0 +1,19 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.fix-case-test + (:require [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]])) + +(defn fix-case-test + "If the node is a :case-test, annotates in the atom shared + by the binding and the local node with :case-test" + {:pass-info {:walk :pre :depends #{#'add-binding-atom}}} + [ast] + (when (:case-test ast) + (swap! (:atom ast) assoc :case-test true)) + ast) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj new file mode 100644 index 000000000..356bf4152 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj @@ -0,0 +1,280 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.infer-tag + (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity]] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u] + [clojure.tools.analyzer.env :as env] + [clojure.set :refer [rename-keys]] + [clojure.tools.analyzer.passes.trim :refer [trim]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [annotate-tag :refer [annotate-tag]] + [annotate-host-info :refer [annotate-host-info]] + [analyze-host-expr :refer [analyze-host-expr]] + [fix-case-test :refer [fix-case-test]]])) + +(defmulti -infer-tag :op) +(defmethod -infer-tag :default [ast] ast) + +(defmethod -infer-tag :binding + [{:keys [init atom] :as ast}] + (if init + (let [info (select-keys init [:return-tag :arglists])] + (swap! atom merge info) + (merge ast info)) + ast)) + +(defmethod -infer-tag :local + [ast] + (let [atom @(:atom ast)] + (merge atom + ast + {:o-tag (:tag atom)}))) + +(defmethod -infer-tag :var + [{:keys [var form] :as ast}] + (let [{:keys [tag arglists]} (:meta ast) + arglists (if (= 'quote (first arglists)) + (second arglists) + arglists) + form-tag (:tag (meta form))] + ;;if (not dynamic) + (merge ast + {:o-tag Object} + (when-let [tag (or form-tag tag)] + (if (fn? @var) + {:tag clojure.lang.AFunction :return-tag tag} + {:tag tag})) + (when arglists + {:arglists arglists})))) + +(defmethod -infer-tag :def + [{:keys [var init name] :as ast}] + (let [info (merge (select-keys init [:return-tag :arglists :tag]) + (select-keys (meta name) [:tag :arglists]))] + (when (and (seq info) + (not (:dynamic (meta name))) + (= :global (-> (env/deref-env) :passes-opts :infer-tag/level))) + (alter-meta! var merge (rename-keys info {:return-tag :tag}))) + (merge ast info {:tag clojure.lang.Var :o-tag clojure.lang.Var}))) + +(defmethod -infer-tag :quote + [ast] + (let [tag (-> ast :expr :tag)] + (assoc ast :tag tag :o-tag tag))) + +(defmethod -infer-tag :new + [ast] + (let [t (-> ast :class :val)] + (assoc ast :o-tag t :tag t))) + +(defmethod -infer-tag :with-meta + [{:keys [expr] :as ast}] + (merge ast (select-keys expr [:return-tag :arglists]) + {:tag (or (:tag expr) Object) :o-tag Object})) ;;trying to be smart here + +(defmethod -infer-tag :recur + [ast] + (assoc ast :ignore-tag true)) + +(defmethod -infer-tag :do + [{:keys [ret] :as ast}] + (merge ast (select-keys ret [:return-tag :arglists :ignore-tag :tag]) + {:o-tag (:tag ret)})) + +(defmethod -infer-tag :let + [{:keys [body] :as ast}] + (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) + {:o-tag (:tag body)})) + +(defmethod -infer-tag :letfn + [{:keys [body] :as ast}] + (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag]) + {:o-tag (:tag body)})) + +(defmethod -infer-tag :loop + [{:keys [body] :as ast}] + (merge ast (select-keys body [:return-tag :arglists]) + {:o-tag (:tag body)} + (let [tag (:tag body)] + (if (#{Void Void/TYPE} tag) + (assoc ast :tag Object) + (assoc ast :tag tag))))) + +(defn =-arglists? [a1 a2] + (let [tag (fn [x] (-> x meta :tag u/maybe-class))] + (and (= a1 a2) + (every? true? (mapv (fn [a1 a2] + (and (= (tag a1) (tag a2)) + (= (mapv tag a1) + (mapv tag a2)))) + a1 a2))))) + +(defmethod -infer-tag :if + [{:keys [then else] :as ast}] + (let [then-tag (:tag then) + else-tag (:tag else) + ignore-then? (:ignore-tag then) + ignore-else? (:ignore-tag else)] + (cond + (and then-tag + (or ignore-else? (= then-tag else-tag))) + (merge ast + {:tag then-tag :o-tag then-tag} + (when-let [return-tag (:return-tag then)] + (when (or ignore-else? + (= return-tag (:return-tag else))) + {:return-tag return-tag})) + (when-let [arglists (:arglists then)] + (when (or ignore-else? + (=-arglists? arglists (:arglists else))) + {:arglists arglists}))) + + (and else-tag ignore-then?) + (merge ast + {:tag else-tag :o-tag else-tag} + (when-let [return-tag (:return-tag else)] + {:return-tag return-tag}) + (when-let [arglists (:arglists else)] + {:arglists arglists})) + + (and (:ignore-tag then) (:ignore-tag else)) + (assoc ast :ignore-tag true) + + :else + ast))) + +(defmethod -infer-tag :throw + [ast] + (assoc ast :ignore-tag true)) + +(defmethod -infer-tag :case + [{:keys [thens default] :as ast}] + (let [thens (conj (mapv :then thens) default) + exprs (seq (remove :ignore-tag thens)) + tag (:tag (first exprs))] + (cond + (and tag + (every? #(= (:tag %) tag) exprs)) + (merge ast + {:tag tag :o-tag tag} + (when-let [return-tag (:return-tag (first exprs))] + (when (every? #(= (:return-tag %) return-tag) exprs) + {:return-tag return-tag})) + (when-let [arglists (:arglists (first exprs))] + (when (every? #(=-arglists? (:arglists %) arglists) exprs) + {:arglists arglists}))) + + (every? :ignore-tag thens) + (assoc ast :ignore-tag true) + + :else + ast))) + +(defmethod -infer-tag :try + [{:keys [body catches] :as ast}] + (let [{:keys [tag return-tag arglists]} body + catches (remove :ignore-tag (mapv :body catches))] + (merge ast + (when (and tag (every? #(= % tag) (mapv :tag catches))) + {:tag tag :o-tag tag}) + (when (and return-tag (every? #(= % return-tag) (mapv :return-tag catches))) + {:return-tag return-tag}) + (when (and arglists (every? #(=-arglists? % arglists) (mapv :arglists catches))) + {:arglists arglists})))) + +(defmethod -infer-tag :fn-method + [{:keys [form body params local] :as ast}] + (let [annotated-tag (or (:tag (meta (first form))) + (:tag (meta (:form local)))) + body-tag (:tag body) + tag (or annotated-tag body-tag) + tag (if (#{Void Void/TYPE} tag) + Object + tag)] + (merge (if (not= tag body-tag) + (assoc-in ast [:body :tag] (u/maybe-class tag)) + ast) + (when tag + {:tag tag + :o-tag tag}) + {:arglist (with-meta (vec (mapcat (fn [{:keys [form variadic?]}] + (if variadic? ['& form] [form])) + params)) + (when tag {:tag tag}))}))) + +(defmethod -infer-tag :fn + [{:keys [local methods] :as ast}] + (merge ast + {:arglists (seq (mapv :arglist methods)) + :tag clojure.lang.AFunction + :o-tag clojure.lang.AFunction} + (when-let [tag (or (:tag (meta (:form local))) + (and (apply = (mapv :tag methods)) + (:tag (first methods))))] + {:return-tag tag}))) + +(defmethod -infer-tag :invoke + [{:keys [fn args] :as ast}] + (if (:arglists fn) + (let [argc (count args) + arglist (arglist-for-arity fn argc) + tag (or (:tag (meta arglist)) + (:return-tag fn) + (and (= :var (:op fn)) + (:tag (:meta fn))))] + (merge ast + (when tag + {:tag tag + :o-tag tag}))) + (if-let [tag (:return-tag fn)] + (assoc ast :tag tag :o-tag tag) + ast))) + +(defmethod -infer-tag :method + [{:keys [form body params] :as ast}] + (let [tag (or (:tag (meta (first form))) + (:tag (meta (second form)))) + body-tag (:tag body)] + (assoc ast :tag (or tag body-tag) :o-tag body-tag))) + +(defmethod -infer-tag :reify + [{:keys [class-name] :as ast}] + (assoc ast :tag class-name :o-tag class-name)) + +(defmethod -infer-tag :set! + [ast] + (let [t (:tag (:target ast))] + (assoc ast :tag t :o-tag t))) + +(defn infer-tag + "Performs local type inference on the AST adds, when possible, + one or more of the following keys to the AST: + * :o-tag represents the current type of the + expression represented by the node + * :tag represents the type the expression represented by the + node is required to have, possibly the same as :o-tag + * :return-tag implies that the node will return a function whose + invocation will result in a object of this type + * :arglists implies that the node will return a function with + this arglists + * :ignore-tag true when the node is untyped, does not imply that + all untyped node will have this + + Passes opts: + * :infer-tag/level If :global, infer-tag will perform Var tag + inference" + {:pass-info {:walk :post :depends #{#'annotate-tag #'annotate-host-info #'fix-case-test #'analyze-host-expr} :after #{#'trim}}} + [{:keys [tag form] :as ast}] + (let [tag (or tag (:tag (meta form))) + ast (-infer-tag ast)] + (merge ast + (when tag + {:tag tag}) + (when-let [o-tag (:o-tag ast)] + {:o-tag o-tag})))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj new file mode 100644 index 000000000..b75304fb5 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj @@ -0,0 +1,274 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate + (:require [clojure.tools.analyzer.ast :refer [prewalk]] + [clojure.tools.analyzer.env :as env] + [clojure.tools.analyzer.passes.cleanup :refer [cleanup]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [validate-recur :refer [validate-recur]] + [infer-tag :refer [infer-tag]] + [analyze-host-expr :refer [analyze-host-expr]]] + [clojure.tools.analyzer.utils :refer [arglist-for-arity source-info resolve-sym resolve-ns merge']] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u :refer [tag-match? try-best-match]]) + (:import (clojure.lang IFn ExceptionInfo))) + +(defmulti -validate :op) + +(defmethod -validate :maybe-class + [{:keys [class env] :as ast}] + (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] + (handle nil class ast) + (if (not (.contains (str class) ".")) + (throw (ex-info (str "Could not resolve var: " class) + (merge {:var class} + (source-info env)))) + + (throw (ex-info (str "Class not found: " class) + (merge {:class class} + (source-info env))))))) + +(defmethod -validate :maybe-host-form + [{:keys [class field form env] :as ast}] + (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)] + (handle class field ast) + (if (resolve-ns class env) + (throw (ex-info (str "No such var: " class) + (merge {:form form} + (source-info env)))) + (throw (ex-info (str "No such namespace: " class) + (merge {:ns class + :form form} + (source-info env))))))) + +(defmethod -validate :set! + [{:keys [target form env] :as ast}] + (when (not (:assignable? target)) + (throw (ex-info "Cannot set! non-assignable target" + (merge {:target (prewalk target cleanup) + :form form} + (source-info env))))) + ast) + +(defmethod -validate :new + [{:keys [args] :as ast}] + (if (:validated? ast) + ast + (if-not (= :class (-> ast :class :type)) + (throw (ex-info (str "Unable to resolve classname: " (:form (:class ast))) + (merge {:class (:form (:class ast)) + :ast ast} + (source-info (:env ast))))) + (let [^Class class (-> ast :class :val) + c-name (symbol (.getName class)) + argc (count args) + tags (mapv :tag args)] + (let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc) + (u/members class c-name)) + (try-best-match tags))] + (if ctor + (if (empty? rest) + (let [arg-tags (mapv u/maybe-class (:parameter-types ctor)) + args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)] + (assoc ast + :args args + :validated? true)) + ast) + (throw (ex-info (str "no ctor found for ctor of class: " class " and given signature") + (merge {:class class + :args (mapv (fn [a] (prewalk a cleanup)) args)} + (source-info (:env ast))))))))))) + +(defn validate-call [{:keys [class instance method args tag env op] :as ast}] + (let [argc (count args) + instance? (= :instance-call op) + f (if instance? u/instance-methods u/static-methods) + tags (mapv :tag args)] + (if-let [matching-methods (seq (f class method argc))] + (let [[m & rest :as matching] (try-best-match tags matching-methods)] + (if m + (let [all-ret-equals? (apply = (mapv :return-type matching))] + (if (or (empty? rest) + (and all-ret-equals? ;; if the method signature is the same just pick the first one + (apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching)))) + (let [ret-tag (:return-type m) + arg-tags (mapv u/maybe-class (:parameter-types m)) + args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags) + class (u/maybe-class (:declaring-class m))] + (merge' ast + {:method (:name m) + :validated? true + :class class + :o-tag ret-tag + :tag (or tag ret-tag) + :args args} + (if instance? + {:instance (assoc instance :tag class)}))) + (if all-ret-equals? + (let [ret-tag (:return-type m)] + (assoc ast + :o-tag Object + :tag (or tag ret-tag))) + ast))) + (if instance? + (assoc (dissoc ast :class) :tag Object :o-tag Object) + (throw (ex-info (str "No matching method: " method " for class: " class " and given signature") + (merge {:method method + :class class + :args (mapv (fn [a] (prewalk a cleanup)) args)} + (source-info env))))))) + (if instance? + (assoc (dissoc ast :class) :tag Object :o-tag Object) + (throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc) + (merge {:method method + :class class + :argc argc} + (source-info env)))))))) + +(defmethod -validate :static-call + [ast] + (if (:validated? ast) + ast + (validate-call (assoc ast :class (u/maybe-class (:class ast)))))) + +(defmethod -validate :static-field + [ast] + (if (:validated? ast) + ast + (assoc ast :class (u/maybe-class (:class ast))))) + +(defmethod -validate :instance-call + [{:keys [class validated? instance] :as ast}] + (let [class (or class (:tag instance))] + (if (and class (not validated?)) + (validate-call (assoc ast :class (u/maybe-class class))) + ast))) + +(defmethod -validate :instance-field + [{:keys [instance class] :as ast}] + (let [class (u/maybe-class class)] + (assoc ast :class class :instance (assoc instance :tag class)))) + +(defmethod -validate :import + [{:keys [^String class validated? env form] :as ast}] + (if-not validated? + (let [class-sym (-> class (subs (inc (.lastIndexOf class "."))) symbol) + sym-val (resolve-sym class-sym env)] + (if (and (class? sym-val) (not= (.getName ^Class sym-val) class)) ;; allow deftype redef + (throw (ex-info (str class-sym " already refers to: " sym-val + " in namespace: " (:ns env)) + (merge {:class class + :class-sym class-sym + :sym-val sym-val + :form form} + (source-info env)))) + (assoc ast :validated? true))) + ast)) + +(defmethod -validate :def + [ast] + (when-not (var? (:var ast)) + (throw (ex-info (str "Cannot def " (:name ast) " as it refers to the class " + (.getName ^Class (:var ast))) + (merge {:ast (prewalk ast cleanup)} + (source-info (:env ast)))))) + (merge + ast + (when-let [tag (-> ast :name meta :tag)] + (when (and (symbol? tag) (or (u/specials (str tag)) (u/special-arrays (str tag)))) + ;; we cannot validate all tags since :tag might contain a function call that returns + ;; a valid tag at runtime, however if tag is one of u/specials or u/special-arrays + ;; we know that it's a wrong tag as it's going to be evaluated as a clojure.core function + (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] + (handle :name/tag ast) + (throw (ex-info (str "Wrong tag: " (eval tag) " in def: " (:name ast)) + (merge {:ast (prewalk ast cleanup)} + (source-info (:env ast)))))))))) + +(defmethod -validate :invoke + [{:keys [args env fn form] :as ast}] + (let [argc (count args)] + (when (and (= :const (:op fn)) + (not (instance? IFn (:form fn)))) + (throw (ex-info (str (class (:form fn)) " is not a function, but it's used as such") + (merge {:form form} + (source-info env))))) + (if (and (:arglists fn) + (not (arglist-for-arity fn argc))) + (if (-> (env/deref-env) :passes-opts :validate/throw-on-arity-mismatch) + (throw (ex-info (str "No matching arity found for function: " (:name fn)) + {:arity (count args) + :fn fn})) + (assoc ast :maybe-arity-mismatch true)) + ast))) + +(defn validate-interfaces [{:keys [env form interfaces]}] + (when-not (every? #(.isInterface ^Class %) (disj interfaces Object)) + (throw (ex-info "only interfaces or Object can be implemented by deftype/reify" + (merge {:interfaces interfaces + :form form} + (source-info env)))))) + +(defmethod -validate :deftype + [{:keys [class-name] :as ast}] + (validate-interfaces ast) + (assoc ast :class-name (u/maybe-class class-name))) + +(defmethod -validate :reify + [{:keys [class-name] :as ast}] + (validate-interfaces ast) + (assoc ast :class-name (u/maybe-class class-name))) + +(defmethod -validate :default [ast] ast) + +(defn validate-tag [t {:keys [env] :as ast}] + (let [tag (ast t)] + (if-let [the-class (u/maybe-class tag)] + {t the-class} + (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)] + (handle t ast) + (throw (ex-info (str "Class not found: " tag) + (merge {:class tag + :ast (prewalk ast cleanup)} + (source-info env)))))))) + +(defn validate + "Validate tags, classes, method calls. + Throws exceptions when invalid forms are encountered, replaces + class symbols with class objects. + + Passes opts: + * :validate/throw-on-arity-mismatch + If true, validate will throw on potential arity mismatch + * :validate/wrong-tag-handler + If bound to a function, will invoke that function instead of + throwing on invalid tag. + The function takes the tag key (or :name/tag if the node is :def and + the wrong tag is the one on the :name field meta) and the originating + AST node and must return a map (or nil) that will be merged into the AST, + possibly shadowing the wrong tag with Object or nil. + * :validate/unresolvable-symbol-handler + If bound to a function, will invoke that function instead of + throwing on unresolvable symbol. + The function takes three arguments: the namespace (possibly nil) + and name part of the symbol, as symbols and the originating + AST node which can be either a :maybe-class or a :maybe-host-form, + those nodes are documented in the tools.analyzer quickref. + The function must return a valid tools.analyzer.jvm AST node." + {:pass-info {:walk :post :depends #{#'infer-tag #'analyze-host-expr #'validate-recur}}} + [{:keys [tag form env] :as ast}] + (let [ast (merge (-validate ast) + (when tag + {:tag tag}))] + (merge ast + (when (:tag ast) + (validate-tag :tag ast)) + (when (:o-tag ast) + (validate-tag :o-tag ast)) + (when (:return-tag ast) + (validate-tag :return-tag ast))))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj new file mode 100644 index 000000000..8d18ea400 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj @@ -0,0 +1,152 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate-loop-locals + (:require [clojure.tools.analyzer.ast :refer [postwalk children update-children]] + [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer [wider-tag maybe-class primitive?]] + [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [validate :refer [validate]] + [classify-invoke :refer [classify-invoke]] + [infer-tag :refer [infer-tag]] + [analyze-host-expr :refer [analyze-host-expr]]])) + +(def ^:dynamic ^:private validating nil) +(def ^:dynamic ^:private mismatch?) +(def ^:dynamic ^:private *loop-locals* []) + +(defn find-mismatches [{:keys [op exprs] :as ast} bindings] + (case op + :recur + (when (some true? (mapv (fn [e {:keys [tag init form]}] + (and (or (primitive? tag) + (not (or (:tag (meta form)) + (:tag (meta (:form init)))))) + (not= (:tag e) tag))) exprs bindings)) + (swap! mismatch? conj (mapv :tag exprs))) + :do + (doseq [child (children ast)] + (find-mismatches child bindings)) + (:let :letfn) + (find-mismatches (:body ast) bindings) + :if + (do (find-mismatches (:then ast) bindings) + (find-mismatches (:else ast) bindings)) + :case + (do (find-mismatches (:default ast) bindings) + (doseq [child (:thens ast)] + (find-mismatches child bindings))) + nil) + ast) + +(defmulti -validate-loop-locals (fn [_ {:keys [op]}] op)) +(defmulti -cleanup-dirty-nodes :op) + +(defmethod -cleanup-dirty-nodes :local + [{:keys [form name atom env] :as ast}] + (if-let [cast ((:loop-locals-casts env) name)] + (assoc ast + :dirty? true + :o-tag cast + :tag (or (:tag (meta form)) cast)) + (if (and (:dirty? @atom) + (not (:tag (meta form)))) + (dissoc (assoc ast :dirty? true) :o-tag :tag) + ast))) + +(defn dirty [ast] + (when-let [atom (:atom ast)] + (swap! atom assoc :dirty? true)) + (assoc (update-children ast (fn [ast] (dissoc ast :dirty?))) + :dirty? true)) + +(defmethod -cleanup-dirty-nodes :do + [{:keys [op ret] :as ast}] + (if (:dirty? ret) + (dissoc (dirty ast) :tag) + ast)) + +;; should check for :tag meta form +(defmethod -cleanup-dirty-nodes :default + [{:keys [op] :as ast}] + (if (some :dirty? (children ast)) + (dissoc (dirty ast) + :tag :validated? (when (= :instance-call op) :class)) + ast)) + +(defn -validate-loop-locals* + [analyze {:keys [body env loop-id] :as ast} key] + (if validating + ast + (binding [mismatch? (atom #{})] + (let [bindings (key ast)] + (find-mismatches body bindings) + (if-let [mismatches (seq @mismatch?)] + (let [bindings-form (apply mapv + (fn [{:keys [form tag]} & mismatches] + (when-not (every? #{tag} mismatches) + (let [tags (conj mismatches tag)] + (with-meta form {:tag (or (and (some primitive? tags) + (wider-tag tags)) + Object)})))) + bindings mismatches) + loop-locals (mapv :name bindings) + binds (zipmap loop-locals (mapv (comp maybe-class :tag meta) bindings-form)) + analyze* (fn [ast] + (analyze (postwalk ast + (fn [ast] + (when-let [atom (:atom ast)] + (swap! atom dissoc :dirty?)) + ast))))] + (binding [validating loop-id + *loop-locals* loop-locals] + (analyze* (dissoc (postwalk (assoc ast key + (mapv (fn [{:keys [atom] :as bind} f] + (if f + (do + (swap! atom assoc :dirty? true) + (assoc (dissoc bind :tag) :form f)) + bind)) + (key ast) bindings-form)) + (comp -cleanup-dirty-nodes + (fn [ast] (assoc-in ast [:env :loop-locals-casts] binds)))) + :dirty?)))) + ast))))) + +(defmethod -validate-loop-locals :loop + [analyze ast] + (-validate-loop-locals* analyze ast :bindings)) + +(defmethod -validate-loop-locals :fn-method + [analyze ast] + (-validate-loop-locals* analyze ast :params)) + +(defmethod -validate-loop-locals :method + [analyze ast] + (-validate-loop-locals* analyze ast :params)) + +(defmethod -validate-loop-locals :recur + [_ {:keys [exprs env loop-id] :as ast}] + (if (= validating loop-id) + (let [casts (:loop-locals-casts env)] + (assoc ast + :exprs (mapv (fn [{:keys [env form] :as e} n] + (if-let [c (casts n)] + (assoc e :tag c) + e)) exprs *loop-locals*))) + ast)) + +(defmethod -validate-loop-locals :default + [_ ast] + ast) + +(defn validate-loop-locals + "Returns a pass that validates the loop locals, calling analyze on the loop AST when + a mismatched loop-local is found" + {:pass-info {:walk :post :depends #{#'validate} :affects #{#'analyze-host-expr #'infer-tag #'validate} :after #{#'classify-invoke}}} + [analyze] + (fn [ast] (-validate-loop-locals analyze ast))) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj new file mode 100644 index 000000000..3058e456b --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj @@ -0,0 +1,40 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate-recur + (:require [clojure.tools.analyzer.ast :refer [update-children]] + [clojure.tools.analyzer.utils :refer [-source-info]])) + +(defmulti validate-recur + "Ensures recurs don't cross try boundaries" + {:pass-info {:walk :pre :depends #{}}} + :op) + +(defmethod validate-recur :default [ast] + (if (-> ast :env :no-recur) + (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true))) + ast)) + +(defmethod validate-recur :try [ast] + (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true)))) + +(defmethod validate-recur :fn-method [ast] + (update-in ast [:env] dissoc :no-recur)) + +(defmethod validate-recur :method [ast] + (update-in ast [:env] dissoc :no-recur)) + +(defmethod validate-recur :loop [ast] + (update-in ast [:env] dissoc :no-recur)) + +(defmethod validate-recur :recur [ast] + (when (-> ast :env :no-recur) + (throw (ex-info "Cannot recur across try" + (merge {:form (:form ast)} + (-source-info (:form ast) (:env ast)))))) + ast) diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj new file mode 100644 index 000000000..8b162e5c2 --- /dev/null +++ b/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj @@ -0,0 +1,62 @@ +;; Copyright (c) Nicola Mometto, Rich Hickey & contributors. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.warn-on-reflection + (:require [nextjournal.clerk.clojure.tools.analyzer.passes.jvm + [validate-loop-locals :refer [validate-loop-locals]] + [validate :refer [validate]]])) + +(defn warn [what {:keys [file line column]}] + (when *warn-on-reflection* + (binding [*err* *out*] + (println (str "Reflection warning: " + (when file + (str file ":")) + (when line + (str line ":")) + (when column + (str column " ")) + "- " what))))) + +(defmulti warn-on-reflection + "Prints a warning to *err* when *warn-on-reflection* is true + and a node requires runtime reflection" + {:pass-info {:walk :pre :depends #{#'validate} :after #{#'validate-loop-locals}}} + :op) + +(defmethod warn-on-reflection :instance-call + [ast] + (when-not (:validated? ast) + (warn (str "call to method " (:method ast) (when-let [class (:class ast)] + (str " on " (.getName ^Class class))) + " cannot be resolved") (:env ast))) + ast) + +(defmethod warn-on-reflection :static-call + [ast] + (when-not (:validated? ast) + (warn (str "call to static method " (:method ast) " on " + (.getName ^Class (:class ast)) " cannot be resolved") + (:env ast))) + ast) + +(defmethod warn-on-reflection :host-interop + [ast] + (warn (str "reference to field or no args method call " (:m-or-f ast) + " cannot be resolved") + (:env ast)) + ast) + +(defmethod warn-on-reflection :new + [ast] + (when-not (:validated? ast) + (warn (str "call to " (.getName ^Class (:val (:class ast))) " ctor cannot be resolved") + (:env ast))) + ast) + +(defmethod warn-on-reflection :default [ast] ast) From b4142bb6ead9781f874ab4c878b5060132b4e50f Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 13:44:54 +0100 Subject: [PATCH 02/16] fix linting --- deps.edn | 2 +- .../nextjournal/clerk => tools-analyzer}/clojure/core/cache.clj | 0 .../clerk => tools-analyzer}/clojure/core/memoize.clj | 0 .../clerk => tools-analyzer}/clojure/data/priority_map.clj | 0 .../clerk => tools-analyzer}/clojure/tools/analyzer/jvm.clj | 0 .../clojure/tools/analyzer/jvm/utils.clj | 0 .../clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj | 0 .../clojure/tools/analyzer/passes/jvm/annotate_branch.clj | 0 .../clojure/tools/analyzer/passes/jvm/annotate_host_info.clj | 0 .../clojure/tools/analyzer/passes/jvm/annotate_loops.clj | 0 .../clojure/tools/analyzer/passes/jvm/annotate_tag.clj | 0 .../clojure/tools/analyzer/passes/jvm/box.clj | 0 .../clojure/tools/analyzer/passes/jvm/classify_invoke.clj | 0 .../clojure/tools/analyzer/passes/jvm/constant_lifter.clj | 0 .../clojure/tools/analyzer/passes/jvm/emit_form.clj | 0 .../clojure/tools/analyzer/passes/jvm/fix_case_test.clj | 0 .../clojure/tools/analyzer/passes/jvm/infer_tag.clj | 0 .../clojure/tools/analyzer/passes/jvm/validate.clj | 0 .../clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj | 0 .../clojure/tools/analyzer/passes/jvm/validate_recur.clj | 0 .../clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj | 0 21 files changed, 1 insertion(+), 1 deletion(-) rename {src/nextjournal/clerk => tools-analyzer}/clojure/core/cache.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/core/memoize.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/data/priority_map.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/jvm.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/jvm/utils.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/annotate_branch.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/annotate_loops.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/annotate_tag.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/box.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/classify_invoke.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/constant_lifter.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/emit_form.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/fix_case_test.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/infer_tag.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/validate.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/validate_recur.clj (100%) rename {src/nextjournal/clerk => tools-analyzer}/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj (100%) diff --git a/deps.edn b/deps.edn index ed460da89..fe2a04b23 100644 --- a/deps.edn +++ b/deps.edn @@ -1,4 +1,4 @@ -{:paths ["src" "resources" "bb"] +{:paths ["src" "resources" "bb" "tools-analyzer"] :deps {org.clojure/clojure {:mvn/version "1.10.3"} org.clojure/java.classpath {:mvn/version "1.0.0"} org.clojure/tools.analyzer {:mvn/version "1.2.0"} diff --git a/src/nextjournal/clerk/clojure/core/cache.clj b/tools-analyzer/clojure/core/cache.clj similarity index 100% rename from src/nextjournal/clerk/clojure/core/cache.clj rename to tools-analyzer/clojure/core/cache.clj diff --git a/src/nextjournal/clerk/clojure/core/memoize.clj b/tools-analyzer/clojure/core/memoize.clj similarity index 100% rename from src/nextjournal/clerk/clojure/core/memoize.clj rename to tools-analyzer/clojure/core/memoize.clj diff --git a/src/nextjournal/clerk/clojure/data/priority_map.clj b/tools-analyzer/clojure/data/priority_map.clj similarity index 100% rename from src/nextjournal/clerk/clojure/data/priority_map.clj rename to tools-analyzer/clojure/data/priority_map.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/clojure/tools/analyzer/jvm.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/jvm.clj rename to tools-analyzer/clojure/tools/analyzer/jvm.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj b/tools-analyzer/clojure/tools/analyzer/jvm/utils.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj rename to tools-analyzer/clojure/tools/analyzer/jvm/utils.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_branch.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_branch.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_loops.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_loops.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_tag.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_tag.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/box.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/box.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/classify_invoke.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/classify_invoke.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/constant_lifter.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/constant_lifter.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/emit_form.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/emit_form.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/fix_case_test.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/fix_case_test.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/infer_tag.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/infer_tag.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/validate.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_recur.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_recur.clj diff --git a/src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj b/tools-analyzer/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj similarity index 100% rename from src/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj rename to tools-analyzer/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj From 42a8e5729cfb23854d14f24d05fd824a0c01cf8a Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 14:01:17 +0100 Subject: [PATCH 03/16] fix --- tools-analyzer/{ => nextjournal/clerk}/clojure/core/cache.clj | 0 tools-analyzer/{ => nextjournal/clerk}/clojure/core/memoize.clj | 0 .../{ => nextjournal/clerk}/clojure/data/priority_map.clj | 0 .../{ => nextjournal/clerk}/clojure/tools/analyzer/jvm.clj | 0 .../{ => nextjournal/clerk}/clojure/tools/analyzer/jvm/utils.clj | 0 .../clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/annotate_branch.clj | 0 .../clojure/tools/analyzer/passes/jvm/annotate_host_info.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/annotate_loops.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/annotate_tag.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/box.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/classify_invoke.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/constant_lifter.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/emit_form.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/fix_case_test.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/infer_tag.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/validate.clj | 0 .../clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj | 0 .../clerk}/clojure/tools/analyzer/passes/jvm/validate_recur.clj | 0 .../clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj | 0 20 files changed, 0 insertions(+), 0 deletions(-) rename tools-analyzer/{ => nextjournal/clerk}/clojure/core/cache.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/core/memoize.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/data/priority_map.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/jvm.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/jvm/utils.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/annotate_branch.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/annotate_loops.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/annotate_tag.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/box.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/classify_invoke.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/constant_lifter.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/emit_form.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/fix_case_test.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/infer_tag.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/validate.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/validate_recur.clj (100%) rename tools-analyzer/{ => nextjournal/clerk}/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj (100%) diff --git a/tools-analyzer/clojure/core/cache.clj b/tools-analyzer/nextjournal/clerk/clojure/core/cache.clj similarity index 100% rename from tools-analyzer/clojure/core/cache.clj rename to tools-analyzer/nextjournal/clerk/clojure/core/cache.clj diff --git a/tools-analyzer/clojure/core/memoize.clj b/tools-analyzer/nextjournal/clerk/clojure/core/memoize.clj similarity index 100% rename from tools-analyzer/clojure/core/memoize.clj rename to tools-analyzer/nextjournal/clerk/clojure/core/memoize.clj diff --git a/tools-analyzer/clojure/data/priority_map.clj b/tools-analyzer/nextjournal/clerk/clojure/data/priority_map.clj similarity index 100% rename from tools-analyzer/clojure/data/priority_map.clj rename to tools-analyzer/nextjournal/clerk/clojure/data/priority_map.clj diff --git a/tools-analyzer/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/jvm.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj diff --git a/tools-analyzer/clojure/tools/analyzer/jvm/utils.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/jvm/utils.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_branch.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_branch.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_loops.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_loops.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_tag.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/annotate_tag.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/box.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/box.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/classify_invoke.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/classify_invoke.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/constant_lifter.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/constant_lifter.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/emit_form.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/emit_form.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/fix_case_test.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/fix_case_test.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/infer_tag.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/infer_tag.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/validate.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_recur.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/validate_recur.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj diff --git a/tools-analyzer/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj similarity index 100% rename from tools-analyzer/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj rename to tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj From 469797a4ee0a91d010f8a54a9dbec784d8b03906 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 14:08:08 +0100 Subject: [PATCH 04/16] fix jar --- build.clj | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/build.clj b/build.clj index f64c660b0..4badd2827 100644 --- a/build.clj +++ b/build.clj @@ -1,6 +1,5 @@ (ns build (:require - [babashka.process :as process] [clojure.string :as str] [clojure.tools.build.api :as b] [nextjournal.clerk.config :as config] @@ -38,7 +37,7 @@ [:license [:name "ISC License"] [:url "https://opensource.org/license/isc-license-txt"]]]]}) - (b/copy-dir {:src-dirs ["src" "resources"] + (b/copy-dir {:src-dirs ["src" "resources" "tools-analyzer"] :target-dir class-dir :replace {}}) (package-clerk-asset-map {:target-dir class-dir}) From dfb2a1d532255308750a3cc618fe82e89263f99f Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 15:59:49 +0100 Subject: [PATCH 05/16] wip [skip ci] --- deps.edn | 2 +- .../clerk/clojure/tools/analyzer/jvm.clj | 49 +++++++++++++++---- 2 files changed, 40 insertions(+), 11 deletions(-) diff --git a/deps.edn b/deps.edn index fe2a04b23..0bb7fe23a 100644 --- a/deps.edn +++ b/deps.edn @@ -5,7 +5,7 @@ ;; org.clojure/tools.analyzer.jvm {:mvn/version "1.3.0"} org.ow2.asm/asm {:mvn/version "9.2"} ;; tools.analyzer dependency babashka/fs {:mvn/version "0.5.22"} - borkdude/edamame {:mvn/version "1.4.24"} + borkdude/edamame {:mvn/version "1.4.28"} weavejester/dependency {:mvn/version "0.2.1"} com.nextjournal/beholder {:mvn/version "1.0.2"} org.flatland/ordered {:mvn/version "1.15.12"} diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj index 8aa0844e7..15511f52b 100644 --- a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj +++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj @@ -128,23 +128,33 @@ (if-let [target (and sym-ns (not (resolve-ns (symbol sym-ns) env)) (maybe-class-literal sym-ns))] ;; Class/field - (let [opname (name form)] + (let [opname (name form) + opname-sym (symbol opname)] (if (and (= (count opname) 1) - (Character/isDigit (char (first opname)))) + (Character/isDigit ^Character (first opname))) form ;; Array/ - (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field) - (meta form)))) + (if (or (.startsWith opname ".") + (let [members (u/members target)] + ;; TODO: only pick non-methods! + (some #(= opname-sym (:name %)) members))) + `(fn + ([x#] (~form x#)) + ;; TODO: analyze method and return properly expanded fn + ) + (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field) + (meta form))))) form))) (defn desugar-host-expr [form env] (let [[op & expr] form] (if (symbol? op) (let [opname (name op) - opns (namespace op)] + opns (namespace op) + opns-class ^Class (maybe-class-literal opns)] (if-let [target (and opns (not (resolve-ns (symbol opns) env)) - (maybe-class-literal opns))] ; (class/field ..) - + (when-not (.startsWith opname ".") + opns-class))] ; (class/field ..) (let [op (symbol opname)] (with-meta (list '. target (if (zero? (count expr)) op @@ -154,10 +164,13 @@ (cond (.startsWith opname ".") ; (.foo bar ..) (let [[target & args] expr - target (if-let [target (maybe-class-literal target)] + target (if opns-class (with-meta (list 'do target) - {:tag 'java.lang.Class}) - target) + {:tag (symbol (.getName opns-class))}) + (if-let [target (maybe-class-literal target)] + (with-meta (list 'do target) + {:tag 'java.lang.Class}) + target)) args (list* (symbol (subs opname 1)) args)] (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is (first args) args)) ;; a method call or a field access @@ -626,3 +639,19 @@ ([form env opts] (binding [run-passes emit-form] (analyze form env opts)))) + +(comment + (analyze+eval '(String/.length "foo")) + (analyze+eval 'String/.length) + (with-bindings {#'ana/macroexpand-1 macroexpand-1 + #'ana/parse parse} + (env/ensure (global-env) + (-analyze '(fn [x] + (String/.length x)) (empty-env)))) + + (macroexpand-1 'String/.length) + (macroexpand-1 'Integer/parseInt) + (clojure.core/macroexpand-1 'Integer/parseInt) + (macroexpand-1 'Long/parseLong) + (eval (macroexpand-1 '(fn [x] + (String/.length x))))) From 6943827733a9e4062301b812c6bf431ac367ea1b Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 16:00:27 +0100 Subject: [PATCH 06/16] wip [skip ci] --- notebooks/qualified_methods.clj | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 notebooks/qualified_methods.clj diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj new file mode 100644 index 000000000..fd2ea1658 --- /dev/null +++ b/notebooks/qualified_methods.clj @@ -0,0 +1,18 @@ +(ns qualified-methods) + +(String/.length "foo") + +(map String/.length ["f" "fo" "foo"]) + +String/1 + +Integer/parseInt + +;; TODO: +;; (String/new "dude") + +;; TODO +;; (map String/new ["dude"]) + +;; TODO +;; (map Integer/parseInt ["1" "2" "3"]) From 22df7384c70e64401fbc18a2bcc308308d67baa6 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 17:53:51 +0100 Subject: [PATCH 07/16] fixiefix --- notebooks/qualified_methods.clj | 4 +++- .../nextjournal/clerk/clojure/tools/analyzer/jvm.clj | 9 +++++++-- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj index fd2ea1658..c13672bf8 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/qualified_methods.clj @@ -6,7 +6,9 @@ String/1 -Integer/parseInt +Integer/parseInt ;; method value + +String/CASE_INSENSITIVE_ORDER ;; field ;; TODO: ;; (String/new "dude") diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj index 15511f52b..d54f9d752 100644 --- a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj +++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj @@ -136,7 +136,9 @@ (if (or (.startsWith opname ".") (let [members (u/members target)] ;; TODO: only pick non-methods! - (some #(= opname-sym (:name %)) members))) + (some #(when (and (= opname-sym (:name %)) + (not (instance? clojure.reflect.Field %))) + %) members))) `(fn ([x#] (~form x#)) ;; TODO: analyze method and return properly expanded fn @@ -654,4 +656,7 @@ (clojure.core/macroexpand-1 'Integer/parseInt) (macroexpand-1 'Long/parseLong) (eval (macroexpand-1 '(fn [x] - (String/.length x))))) + (String/.length x)))) + + (macroexpand-1 'clojure.lang.Compiler/LOADER) + ) From d491baef20dd4aeae5e76afa0a1b5ec520c52b15 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 20:13:09 +0100 Subject: [PATCH 08/16] yes --- notebooks/qualified_methods.clj | 11 +++---- .../clerk/clojure/tools/analyzer/jvm.clj | 33 ++++++++++++------- 2 files changed, 27 insertions(+), 17 deletions(-) diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj index c13672bf8..6e4bd68be 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/qualified_methods.clj @@ -10,11 +10,10 @@ Integer/parseInt ;; method value String/CASE_INSENSITIVE_ORDER ;; field -;; TODO: -;; (String/new "dude") +(String/new "dude") ;; constructor -;; TODO -;; (map String/new ["dude"]) +String/new -;; TODO -;; (map Integer/parseInt ["1" "2" "3"]) +(map String/new ["dude"]) + +(map Integer/parseInt ["1" "2" "3"]) diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj index d54f9d752..843cf0057 100644 --- a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj +++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj @@ -133,16 +133,23 @@ (if (and (= (count opname) 1) (Character/isDigit ^Character (first opname))) form ;; Array/ - (if (or (.startsWith opname ".") - (let [members (u/members target)] - ;; TODO: only pick non-methods! - (some #(when (and (= opname-sym (:name %)) - (not (instance? clojure.reflect.Field %))) - %) members))) + (cond + (= "new" opname) + `(fn + ([x#] (new ~(symbol sym-ns) x#)) + ;; TODO: analyze method and return properly expanded fn + ) + (or (.startsWith opname ".") + (let [members (u/members target)] + ;; TODO: only pick non-methods! + (some #(when (and (= opname-sym (:name %)) + (not (instance? clojure.reflect.Field %))) + %) members))) `(fn ([x#] (~form x#)) ;; TODO: analyze method and return properly expanded fn ) + :else (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field) (meta form))))) form))) @@ -158,10 +165,13 @@ (when-not (.startsWith opname ".") opns-class))] ; (class/field ..) (let [op (symbol opname)] - (with-meta (list '. target (if (zero? (count expr)) - op - (list* op expr))) - (meta form))) + (if (= 'new op) + (with-meta (list* 'new (symbol opns) expr) + (meta form)) + (with-meta (list '. target (if (zero? (count expr)) + op + (list* op expr))) + (meta form)))) (cond (.startsWith opname ".") ; (.foo bar ..) @@ -181,7 +191,6 @@ (.endsWith opname ".") ;; (class. ..) (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr) (meta form)) - :else form))) form))) @@ -659,4 +668,6 @@ (String/.length x)))) (macroexpand-1 'clojure.lang.Compiler/LOADER) + (macroexpand-1 '(String/new "foo")) + (macroexpand-1 'String/new) ) From 484a6bc378ecb4f83630239fd8822c5aff47a88c Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Mon, 17 Mar 2025 20:13:49 +0100 Subject: [PATCH 09/16] make CI fail --- notebooks/qualified_methods.clj | 2 ++ 1 file changed, 2 insertions(+) diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj index 6e4bd68be..fa1e5dc3a 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/qualified_methods.clj @@ -17,3 +17,5 @@ String/new (map String/new ["dude"]) (map Integer/parseInt ["1" "2" "3"]) + +(throw (ex-info "dude" {})) ;; this if CI fails From b67f816ec7fc6ce0b0a1417705e47e0172405023 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 11:43:18 +0100 Subject: [PATCH 10/16] Add test --- notebooks/qualified_methods.clj | 2 +- test/nextjournal/clerk/clojure_1_12_test.clj | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) create mode 100644 test/nextjournal/clerk/clojure_1_12_test.clj diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj index fa1e5dc3a..790ef4b3d 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/qualified_methods.clj @@ -10,6 +10,7 @@ Integer/parseInt ;; method value String/CASE_INSENSITIVE_ORDER ;; field +;; TODO: get rid of reflection (String/new "dude") ;; constructor String/new @@ -18,4 +19,3 @@ String/new (map Integer/parseInt ["1" "2" "3"]) -(throw (ex-info "dude" {})) ;; this if CI fails diff --git a/test/nextjournal/clerk/clojure_1_12_test.clj b/test/nextjournal/clerk/clojure_1_12_test.clj new file mode 100644 index 000000000..018294cdd --- /dev/null +++ b/test/nextjournal/clerk/clojure_1_12_test.clj @@ -0,0 +1,6 @@ +(ns nextjournal.clerk.clojure-1-12-test + (:require [clojure.test :as t :refer [deftest is]] + [nextjournal.clerk :as clerk])) + +(deftest notebook-is-analyzed-without-errors-test + (is (clerk/show! "notebooks/qualified_methods.clj"))) From eac6fe20054e233fae5561952fe0bedb7ef4c2df Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 12:28:51 +0100 Subject: [PATCH 11/16] run with 1.12 --- .github/workflows/main.yml | 7 ++++++- bb.edn | 6 +++++- deps.edn | 2 ++ test/nextjournal/clerk/clojure_1_12_test.clj | 6 ++++-- 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index a3bbc13db..f14189234 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -69,6 +69,9 @@ jobs: - { os: macos-latest, shell: bash } - { os: ubuntu-latest, shell: bash } - { os: windows-latest, shell: powershell } + clojure: + - 1.10.3 + - 1.12.0 defaults: run: @@ -98,7 +101,9 @@ jobs: key: ${{ runner.os }}-maven-test-${{ hashFiles('deps.edn') }} - name: 🧪 Run tests - run: bb test:clj :kaocha/reporter '[kaocha.report/documentation]' + run: | + bb test:clj :kaocha/reporter '[kaocha.report/documentation]' \ + :clojure '"${{ matrix.clojure }}"' static-build: runs-on: ubuntu-latest diff --git a/bb.edn b/bb.edn index 15c19a7ab..2fcb7d934 100644 --- a/bb.edn +++ b/bb.edn @@ -50,7 +50,11 @@ :task (run '-check {:parallel true})} test:clj {:doc "Run clojure tests" - :task (apply clojure "-X:test" *command-line-args*)} + :task + (let [{clojure-version :clojure} (cli/parse-opts *command-line-args*)] + (apply clojure (cond-> "-X:test" + clojure (str ":" clojure-version)) + *command-line-args*))} playwright:version {:doc "Print used playwright version from ui_tests/yarn.json" :task (print (->> (babashka.process/shell {:out :string} "grep -E 'playwright-core \"(.*)\"' ui_tests/yarn.lock") diff --git a/deps.edn b/deps.edn index 0bb7fe23a..d5bc45713 100644 --- a/deps.edn +++ b/deps.edn @@ -76,6 +76,8 @@ ;; Run a single test: ;; clj -M:test -v nextjournal.clerk.analyzer-test/analyze-doc :main-opts ["-m" "cognitect.test-runner"]} + :1.10.3 {:extra-deps {org.clojure/clojure {:mvn/version "1.10.3"}}} + :1.12.0 {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0"}}} :demo {:extra-paths ["demo"] :extra-deps {com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"} diff --git a/test/nextjournal/clerk/clojure_1_12_test.clj b/test/nextjournal/clerk/clojure_1_12_test.clj index 018294cdd..6c48299bc 100644 --- a/test/nextjournal/clerk/clojure_1_12_test.clj +++ b/test/nextjournal/clerk/clojure_1_12_test.clj @@ -2,5 +2,7 @@ (:require [clojure.test :as t :refer [deftest is]] [nextjournal.clerk :as clerk])) -(deftest notebook-is-analyzed-without-errors-test - (is (clerk/show! "notebooks/qualified_methods.clj"))) +(when (>= (:minor *clojure-version*) 12) + (deftest notebook-is-analyzed-without-errors-test + (is (do (clerk/show! "notebooks/qualified_methods.clj") + true)))) From 1eb71b3822922814329e5586c934a50ad477224e Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 12:30:38 +0100 Subject: [PATCH 12/16] bash --- .github/workflows/main.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index f14189234..310f4643b 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -101,6 +101,7 @@ jobs: key: ${{ runner.os }}-maven-test-${{ hashFiles('deps.edn') }} - name: 🧪 Run tests + shell: bash run: | bb test:clj :kaocha/reporter '[kaocha.report/documentation]' \ :clojure '"${{ matrix.clojure }}"' From 7a75568be732f284443e043270e249927704cb27 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 13:53:57 +0100 Subject: [PATCH 13/16] avoid reflection --- notebooks/qualified_methods.clj | 9 ++++----- .../nextjournal/clerk/clojure/tools/analyzer/jvm.clj | 4 ++-- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/notebooks/qualified_methods.clj b/notebooks/qualified_methods.clj index 790ef4b3d..8f32244bf 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/qualified_methods.clj @@ -1,4 +1,5 @@ -(ns qualified-methods) +(ns qualified-methods + {:nextjournal.clerk/no-cache true}) (String/.length "foo") @@ -10,12 +11,10 @@ Integer/parseInt ;; method value String/CASE_INSENSITIVE_ORDER ;; field -;; TODO: get rid of reflection (String/new "dude") ;; constructor -String/new +^[String] String/new -(map String/new ["dude"]) +(map ^[String] String/new ["dude"]) (map Integer/parseInt ["1" "2" "3"]) - diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj index 843cf0057..81d7f629e 100644 --- a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj +++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj @@ -136,7 +136,7 @@ (cond (= "new" opname) `(fn - ([x#] (new ~(symbol sym-ns) x#)) + ([x#] (new ~(symbol sym-ns) x# d)) ;; TODO: analyze method and return properly expanded fn ) (or (.startsWith opname ".") @@ -669,5 +669,5 @@ (macroexpand-1 'clojure.lang.Compiler/LOADER) (macroexpand-1 '(String/new "foo")) - (macroexpand-1 'String/new) + ) From bae3093d25e0f7336f69471be0809e9555d025d6 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 13:56:00 +0100 Subject: [PATCH 14/16] rename notebook --- notebooks/{qualified_methods.clj => clojure_1_12/clj.clj} | 2 +- test/nextjournal/clerk/clojure_1_12_test.clj | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) rename notebooks/{qualified_methods.clj => clojure_1_12/clj.clj} (93%) diff --git a/notebooks/qualified_methods.clj b/notebooks/clojure_1_12/clj.clj similarity index 93% rename from notebooks/qualified_methods.clj rename to notebooks/clojure_1_12/clj.clj index 8f32244bf..4e945cefc 100644 --- a/notebooks/qualified_methods.clj +++ b/notebooks/clojure_1_12/clj.clj @@ -1,4 +1,4 @@ -(ns qualified-methods +(ns clojure-1-12.clj {:nextjournal.clerk/no-cache true}) (String/.length "foo") diff --git a/test/nextjournal/clerk/clojure_1_12_test.clj b/test/nextjournal/clerk/clojure_1_12_test.clj index 6c48299bc..50b604dfb 100644 --- a/test/nextjournal/clerk/clojure_1_12_test.clj +++ b/test/nextjournal/clerk/clojure_1_12_test.clj @@ -4,5 +4,5 @@ (when (>= (:minor *clojure-version*) 12) (deftest notebook-is-analyzed-without-errors-test - (is (do (clerk/show! "notebooks/qualified_methods.clj") + (is (do (clerk/show! "notebooks/clojure_1_12.clj") true)))) From 679f1e4abae9128342dc98b8c36fd5c374ab82f3 Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 13:57:17 +0100 Subject: [PATCH 15/16] clojure 1.12 --- notebooks/{clojure_1_12/clj.clj => clojure_1_12.clj} | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) rename notebooks/{clojure_1_12/clj.clj => clojure_1_12.clj} (93%) diff --git a/notebooks/clojure_1_12/clj.clj b/notebooks/clojure_1_12.clj similarity index 93% rename from notebooks/clojure_1_12/clj.clj rename to notebooks/clojure_1_12.clj index 4e945cefc..4a0cbb28b 100644 --- a/notebooks/clojure_1_12/clj.clj +++ b/notebooks/clojure_1_12.clj @@ -1,4 +1,4 @@ -(ns clojure-1-12.clj +(ns clojure-1-12 {:nextjournal.clerk/no-cache true}) (String/.length "foo") From feac79f650d2882373232220b9a960b11b05195e Mon Sep 17 00:00:00 2001 From: Michiel Borkent Date: Tue, 18 Mar 2025 14:11:32 +0100 Subject: [PATCH 16/16] bump clojure --- deps.edn | 2 +- notebooks/clojure_1_12.clj | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/deps.edn b/deps.edn index d5bc45713..c8a0c1a3d 100644 --- a/deps.edn +++ b/deps.edn @@ -40,7 +40,7 @@ :sci {:extra-deps {io.github.nextjournal/clerk.render {:local/root "render"}}} - :dev {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0-beta1"} ;; for `:as-alias` & `add-lib` support but only in dev + :dev {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0"} ;; for `:as-alias` & `add-lib` support but only in dev arrowic/arrowic {:mvn/version "0.1.1"} binaryage/devtools {:mvn/version "1.0.3"} cider/cider-nrepl {:mvn/version "0.49.3"} diff --git a/notebooks/clojure_1_12.clj b/notebooks/clojure_1_12.clj index 4a0cbb28b..eb6a52414 100644 --- a/notebooks/clojure_1_12.clj +++ b/notebooks/clojure_1_12.clj @@ -1,5 +1,4 @@ -(ns clojure-1-12 - {:nextjournal.clerk/no-cache true}) +(ns clojure-1-12) (String/.length "foo")