diff --git a/spike/native/dump-ir.janet b/spike/native/dump-ir.janet new file mode 100644 index 0000000..d6a751c --- /dev/null +++ b/spike/native/dump-ir.janet @@ -0,0 +1,15 @@ +# Dump the analyzed IR (not emitted Janet) for count-point, so the C emitter can +# be written against the real node shapes. jolt-ihdp. +(import ../../src/jolt/api :as api) +(import ../../src/jolt/backend :as backend) +(import ../../src/jolt/reader :as reader) + +(def ctx (api/init-cached {:compile? true})) +(put (ctx :env) :direct-linking? true) +(put (ctx :env) :inline? true) +(api/eval-string ctx "(ns mandelbrot)") + +(def src "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") + +(def ir (backend/analyze-form ctx (reader/parse-string src))) +(printf "%P" ir) diff --git a/src/jolt/cgen.janet b/src/jolt/cgen.janet new file mode 100644 index 0000000..7efbd22 --- /dev/null +++ b/src/jolt/cgen.janet @@ -0,0 +1,243 @@ +# Native code generation: jolt IR -> C, for hot numeric-leaf fns (jolt-ihdp, the +# lever-1 native-codegen tier of epic jolt-5vsp). The spike +# (docs/foundational-runtime-lever1-native-codegen.md) showed native-C compute +# beats the Janet-VM floor (~18-22x faster than bytecode, edges out JVM Clojure), +# and that compiling a hot LEAF fn to C — called from a bytecode loop — captures +# the win because the forward (bytecode -> C) crossing is nearly free. +# +# This module is the IR -> C translator + a cc/load driver. It is a standalone +# library: nothing wires it into the default compile path yet (that — detecting +# hot fns and installing the C version onto the var cell — is the next step). A +# fn is a candidate only if its whole body is numeric (params/locals/return are +# numbers, all calls are native-op arithmetic): then everything stays in C +# `double`s, unboxed at entry and reboxed at return, with no Janet in the hot loop. +(import ./core_types :as ct) +(import ./phm :as phm) + +(defn- norm-node [n] (if (phm/phm? n) (phm/phm-to-struct n) n)) + +# jolt core fn name -> {:c "" :kind :infix|:incdec}. The subset of +# backend/native-ops that maps to a C double operator with matching semantics. +# (mod/rem/bit-ops/min/max deliberately omitted for now — they need helper calls +# or differ from C operators; add them as the candidate grammar grows.) +(def- c-ops + {"+" {:c "+" :kind :infix} "-" {:c "-" :kind :infix} + "*" {:c "*" :kind :infix} "/" {:c "/" :kind :infix} + "<" {:c "<" :kind :infix} ">" {:c ">" :kind :infix} + "<=" {:c "<=" :kind :infix} ">=" {:c ">=" :kind :infix} + "=" {:c "==" :kind :infix} + "inc" {:c "+" :kind :incdec} "dec" {:c "-" :kind :incdec}}) + +(defn- args-of [node] (ct/vview (node :args))) + +# A native-op invoke -> its c-ops entry, else nil (the head must be a clojure.core +# ref to a supported primitive at the right arity). +(defn- op-for [node] + (def n (norm-node node)) + (def f (and (= :invoke (n :op)) (norm-node (n :fn)))) + (and f (= :var (f :op)) (= "clojure.core" (f :ns)) + (let [op (get c-ops (f :name)) + nargs (length (args-of n))] + (and op + (if (= (op :kind) :incdec) (= 1 nargs) (= 2 nargs)) + op)))) + +# --- candidate check: every node in the body is C-translatable --- +(var- numeric-ok? nil) +(defn- bindings-ok? [node] + (all (fn [pair] (numeric-ok? (in (ct/vview pair) 1))) (ct/vview (node :bindings)))) +(set numeric-ok? + (fn numeric-ok? [raw] + (def node (norm-node raw)) + (case (node :op) + :const (number? (node :val)) + :local true + :if (and (numeric-ok? (node :test)) (numeric-ok? (node :then)) (numeric-ok? (node :else))) + :do (and (all numeric-ok? (ct/vview (node :statements))) (numeric-ok? (node :ret))) + :let (and (bindings-ok? node) (numeric-ok? (node :body))) + :loop (and (bindings-ok? node) (numeric-ok? (node :body))) + :recur (all numeric-ok? (args-of node)) + :invoke (and (op-for node) (all numeric-ok? (args-of node))) + false))) + +(defn fn-ir-of + "Unwrap a :def-of-fn or a bare :fn IR node to the :fn node, or nil." + [ir] + (def n (norm-node ir)) + (def init (norm-node (get n :init n))) + (and (= :fn (init :op)) init)) + +(defn numeric-leaf? + "True when ir is a single-fixed-arity fn whose entire body is C-translatable + (numeric in, numeric out, only native-op arithmetic)." + [ir] + (def fnode (fn-ir-of ir)) + (and fnode + (let [ars (ct/vview (fnode :arities))] + (and (= 1 (length ars)) + (not ((first ars) :rest)) + (numeric-ok? ((first ars) :body)))))) + +# --- C generation --- +# scope: jolt-local-name (string) -> C var name. Fresh C names sidestep charset +# and keyword collisions. rctx (recur target): {:vars [c-names] :flag flag-name}. + +(defn- new-namer [] + (def counter @[0]) + (fn [] (def n (in counter 0)) (put counter 0 (+ n 1)) (string "v" n))) + +(defn- fmtnum [x] + (def s (string/format "%.17g" (* 1.0 x))) + (if (or (string/find "." s) (string/find "e" s) (string/find "n" s)) s (string s ".0"))) + +(var- c-expr nil) +(set c-expr + (fn c-expr [raw scope] + (def node (norm-node raw)) + (case (node :op) + :const (fmtnum (node :val)) + :local (or (get scope (node :name)) (error (string "cgen: unbound local " (node :name)))) + :invoke (let [op (op-for node) as (args-of node)] + (if (= (op :kind) :incdec) + (string "(" (c-expr (in as 0) scope) " " (op :c) " 1)") + (string "(" (c-expr (in as 0) scope) " " (op :c) " " (c-expr (in as 1) scope) ")"))) + (error (string "cgen: non-pure op in expr position: " (node :op)))))) + +(defn- pure? [node] + (case (node :op) :const true :local true :invoke (truthy? (op-for node)) false)) + +# emit-to: append C statements that compute node's (double) value into dest. +# Control-flow forms (if/do/let/loop/recur) lower to statements; pure nodes to a +# single assignment. A comparison yields C int 0/1, which is a fine double here. +(var- emit-to nil) +(set emit-to + (fn emit-to [raw dest scope rctx out namer] + (def node (norm-node raw)) + (case (node :op) + :if (let [t (namer)] + (buffer/push out "double " t ";\n") + (emit-to (node :test) t scope rctx out namer) + (buffer/push out "if (" t " != 0.0) {\n") + (emit-to (node :then) dest scope rctx out namer) + (buffer/push out "} else {\n") + (emit-to (node :else) dest scope rctx out namer) + (buffer/push out "}\n")) + :do (do (each s (ct/vview (node :statements)) + (def junk (namer)) (buffer/push out "double " junk ";\n") + (emit-to s junk scope rctx out namer)) + (emit-to (node :ret) dest scope rctx out namer)) + :let (let [scope2 (table/clone scope)] + (each pair (ct/vview (node :bindings)) + (def p (ct/vview pair)) + (def cv (namer)) + (buffer/push out "double " cv ";\n") + (emit-to (in p 1) cv scope2 rctx out namer) + (put scope2 (string (in p 0)) cv)) + (emit-to (node :body) dest scope2 rctx out namer)) + :loop (let [scope2 (table/clone scope) cvars @[] flag (namer)] + (each pair (ct/vview (node :bindings)) + (def p (ct/vview pair)) + (def cv (namer)) + (buffer/push out "double " cv ";\n") + (emit-to (in p 1) cv scope2 rctx out namer) + (put scope2 (string (in p 0)) cv) + (array/push cvars cv)) + (buffer/push out "int " flag " = 1;\n") + (buffer/push out "while (" flag ") {\n" flag " = 0;\n") + (emit-to (node :body) dest scope2 {:vars cvars :flag flag} out namer) + (buffer/push out "}\n")) + # recur: compute new values into temps first (avoid clobbering loop vars + # mid-update), then assign and set the continue flag. Produces no value — + # the enclosing while re-runs. + :recur (let [as (args-of node) tmps @[]] + (each a as + (def tv (namer)) + (buffer/push out "double " tv ";\n") + (emit-to a tv scope rctx out namer) + (array/push tmps tv)) + (for i 0 (length tmps) + (buffer/push out (in (rctx :vars) i) " = " (in tmps i) ";\n")) + (buffer/push out (rctx :flag) " = 1;\n")) + (if (pure? node) + (buffer/push out dest " = " (c-expr node scope) ";\n") + (error (string "cgen: unsupported op " (node :op))))))) + +(defn- sanitize [name] + (def b @"") + (each c name + (buffer/push b (if (or (and (>= c 97) (<= c 122)) (and (>= c 65) (<= c 90)) + (and (>= c 48) (<= c 57)) (= c 95)) c 95))) + (string b)) + +(defn gen-c-fn + "ir (a numeric-leaf :def-of-fn or :fn node), c-name -> a C source string for a + Janet native module exporting `c-name` as a cfunction. Assumes (numeric-leaf? ir)." + [ir c-name] + (def fnode (fn-ir-of ir)) + (def ar (first (ct/vview (fnode :arities)))) + (def params (map string (ct/vview (ar :params)))) + (def namer (new-namer)) + (def scope @{}) + (def pre @"") + (buffer/push pre "#include \n") + (buffer/push pre "static Janet cfun_" c-name "(int32_t argc, Janet *argv) {\n") + (buffer/push pre "janet_fixarity(argc, " (string (length params)) ");\n") + (eachp [i pn] params + (def cv (namer)) + (buffer/push pre "double " cv " = janet_getnumber(argv, " (string i) ");\n") + (put scope pn cv)) + (def out @"") + (def ret (namer)) + (buffer/push out "double " ret ";\n") + (emit-to (ar :body) ret scope nil out namer) + (string pre out + "return janet_wrap_number(" ret ");\n}\n" + "static const JanetReg cfuns[] = {{\"" c-name "\", cfun_" c-name + ", NULL}, {NULL, NULL, NULL}};\n" + "JANET_MODULE_ENTRY(JanetTable *env) { janet_cfuns(env, \"cg\", cfuns); }\n")) + +# --- toolchain --- +(defn header-dir + "Directory containing janet.h, probed from syspath + common prefixes, or nil." + [] + (def sp (dyn :syspath)) + (def cands @[(string sp "/../../include") "/opt/homebrew/include" + "/usr/local/include" "/usr/include"]) + (var found nil) + (each c cands (when (and (not found) (os/stat (string c "/janet.h"))) (set found c))) + found) + +(defn toolchain-available? + "True when a C compiler and janet.h are present (so compile-fn can work)." + [] + (and (header-dir) + (= 0 (os/execute ["cc" "--version"] :px + {:out (file/open "/dev/null" :w) :err (file/open "/dev/null" :w)})))) + +(defn compile-fn + "Compile a numeric-leaf fn IR to a native Janet cfunction. Returns the + cfunction, or nil if ir isn't a candidate or the toolchain is unavailable. + opts: :dir (build dir, default \"build/cgen\"), :name (C identifier base). + cc errors propagate (a compiler crash is a cgen bug, not a punt)." + [ir &opt opts] + (default opts {}) + (when (and (numeric-leaf? ir) (header-dir)) + (def dir (get opts :dir "build/cgen")) + (def c-name (sanitize (get opts :name "jolt_cfn"))) + (os/mkdir dir) + (def src (gen-c-fn ir c-name)) + (def cpath (string dir "/" c-name ".c")) + (def sopath (string dir "/" c-name ".so")) + (spit cpath src) + # macOS needs -undefined dynamic_lookup so the module's janet_* refs resolve + # against the host at load time; ELF (Linux/BSD) resolves them then anyway. + (def mac? (= :macos (os/which))) + (def cmd @["cc" "-shared" "-fPIC" "-O2" (string "-I" (header-dir))]) + (when mac? (array/push cmd "-undefined") (array/push cmd "dynamic_lookup")) + (array/push cmd cpath "-o" sopath) + (def r (os/execute cmd :p)) + (unless (= 0 r) (error (string "cgen: cc failed (" r ") for " cpath))) + (def abs (if (= (in sopath 0) (chr "/")) sopath (string (os/cwd) "/" sopath))) + (def env @{}) + (native abs env) + ((get env (symbol c-name)) :value))) diff --git a/test/integration/cgen-test.janet b/test/integration/cgen-test.janet new file mode 100644 index 0000000..9cb027e --- /dev/null +++ b/test/integration/cgen-test.janet @@ -0,0 +1,71 @@ +# Native codegen (jolt-ihdp): IR -> C for numeric-leaf fns. Pins that the C +# translator (1) classifies candidates correctly and (2) produces a native fn +# whose results match the bytecode/interpreted fn over the mandelbrot grid. +# Skips cleanly where the C toolchain (cc + janet.h) is absent — the rest of the +# gate still runs. +(import ../../src/jolt/api :as api) +(import ../../src/jolt/backend :as backend) +(import ../../src/jolt/reader :as reader) +(import ../../src/jolt/cgen :as cgen) + +(print "Native codegen IR->C (jolt-ihdp)...") + +(def ctx (api/init-cached {:compile? true})) +(put (ctx :env) :direct-linking? true) +(put (ctx :env) :inline? true) +(api/eval-string ctx "(ns cgentest)") + +(defn ir-of [src] (backend/analyze-form ctx (reader/parse-string src))) + +(def count-point-src + "(defn count-point [cr ci cap] (loop [i 0 zr 0.0 zi 0.0] (if (or (>= i cap) (> (+ (* zr zr) (* zi zi)) 4.0)) i (recur (inc i) (+ (- (* zr zr) (* zi zi)) cr) (+ (* 2.0 (* zr zi)) ci)))))") + +(var failures 0) +(defn check [label ok] (unless ok (++ failures) (eprintf " FAIL: %s" label))) + +# --- classification --- +(check "count-point is a numeric leaf" (cgen/numeric-leaf? (ir-of count-point-src))) +(check "fn calling a non-native fn is NOT a leaf" + (not (cgen/numeric-leaf? (ir-of "(defn f [x] (str x))")))) +(check "fn building a collection is NOT a leaf" + (not (cgen/numeric-leaf? (ir-of "(defn f [x] [x x])")))) +(check "plain numeric expr fn IS a leaf" + (cgen/numeric-leaf? (ir-of "(defn sq [x] (* x x))"))) + +# --- C generation is well-formed (smoke: contains the wrapper + a loop) --- +(def c-src (cgen/gen-c-fn (ir-of count-point-src) "count_point")) +(check "emits a cfunction wrapper" (string/find "cfun_count_point" c-src)) +(check "lowers the loop to a C while" (string/find "while (" c-src)) +(check "unboxes params with janet_getnumber" (string/find "janet_getnumber" c-src)) + +# --- behavioral equivalence (only where the toolchain is present) --- +(if (cgen/toolchain-available?) + (do + (api/eval-string ctx count-point-src) + (def bc-cp (api/eval-string ctx "count-point")) # the compiled/interpreted fn + (def c-cp (cgen/compile-fn (ir-of count-point-src) + {:dir "build/cgen-test" :name "count_point_test"})) + (defn callable? [x] (or (function? x) (cfunction? x))) + (check "compile-fn returns a callable" (callable? c-cp)) + (when (callable? c-cp) + # spot points spanning escape-fast .. in-set + (var ptmatch true) + (each [cr ci] [[2.0 2.0] [0.5 0.5] [-0.5 0.6] [0.28 0.0] [-0.74 0.1] [-0.5 0.0] [0.0 0.0]] + (unless (= (c-cp cr ci 200) (bc-cp cr ci 200)) (set ptmatch false))) + (check "C count-point matches bytecode on sample points" ptmatch) + # full mandelbrot grid total + (defn grid-total [cp n] + (def cap 200) (def nd (* 1.0 n)) (var acc 0) (var y 0) + (while (< y n) + (def ci (- (/ (* 2.0 y) nd) 1.0)) (var x 0) (var a 0) + (while (< x n) + (def cr (- (/ (* 2.0 x) nd) 1.5)) (set a (+ a (cp cr ci cap))) (++ x)) + (set acc (+ acc a)) (++ y)) + acc) + (check "C and bytecode agree on the full n=80 grid total" + (= (grid-total c-cp 80) (grid-total bc-cp 80))))) + (print " (toolchain absent — skipping behavioral equivalence)")) + +(if (= 0 failures) + (print "All tests passed.") + (do (eprintf "%d cgen check(s) failed" failures) (os/exit 1)))