From e4f2969ff13ad2b7a16299d8627e9188de555390 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 29 Jan 2017 19:28:36 -0400 Subject: - Major refactoring to make it easier to introduce the new (JS) backend. --- luxc/src/lux.clj | 1 - luxc/src/lux/analyser.clj | 4 +- luxc/src/lux/analyser/host.clj | 1360 ----------------- luxc/src/lux/analyser/jvm.clj | 1360 +++++++++++++++++ luxc/src/lux/analyser/module.clj | 13 + luxc/src/lux/compiler.clj | 276 +--- luxc/src/lux/compiler/base.clj | 112 -- luxc/src/lux/compiler/cache.clj | 274 ---- luxc/src/lux/compiler/case.clj | 214 --- luxc/src/lux/compiler/core.clj | 82 + luxc/src/lux/compiler/host.clj | 2762 ---------------------------------- luxc/src/lux/compiler/io.clj | 2 +- luxc/src/lux/compiler/jvm.clj | 228 +++ luxc/src/lux/compiler/jvm/base.clj | 87 ++ luxc/src/lux/compiler/jvm/cache.clj | 275 ++++ luxc/src/lux/compiler/jvm/case.clj | 214 +++ luxc/src/lux/compiler/jvm/host.clj | 2762 ++++++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/lambda.clj | 281 ++++ luxc/src/lux/compiler/jvm/lux.clj | 493 ++++++ luxc/src/lux/compiler/lambda.clj | 281 ---- luxc/src/lux/compiler/lux.clj | 493 ------ luxc/src/lux/compiler/module.clj | 23 - luxc/src/lux/repl.clj | 2 +- 23 files changed, 5821 insertions(+), 5778 deletions(-) delete mode 100644 luxc/src/lux/analyser/host.clj create mode 100644 luxc/src/lux/analyser/jvm.clj delete mode 100644 luxc/src/lux/compiler/base.clj delete mode 100644 luxc/src/lux/compiler/cache.clj delete mode 100644 luxc/src/lux/compiler/case.clj create mode 100644 luxc/src/lux/compiler/core.clj delete mode 100644 luxc/src/lux/compiler/host.clj create mode 100644 luxc/src/lux/compiler/jvm.clj create mode 100644 luxc/src/lux/compiler/jvm/base.clj create mode 100644 luxc/src/lux/compiler/jvm/cache.clj create mode 100644 luxc/src/lux/compiler/jvm/case.clj create mode 100644 luxc/src/lux/compiler/jvm/host.clj create mode 100644 luxc/src/lux/compiler/jvm/lambda.clj create mode 100644 luxc/src/lux/compiler/jvm/lux.clj delete mode 100644 luxc/src/lux/compiler/lambda.clj delete mode 100644 luxc/src/lux/compiler/lux.clj delete mode 100644 luxc/src/lux/compiler/module.clj (limited to 'luxc/src') diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj index 76778346d..182ddf46f 100644 --- a/luxc/src/lux.clj +++ b/luxc/src/lux.clj @@ -1,7 +1,6 @@ (ns lux (:gen-class) (:require [lux.base :as & :refer [|let |do return return* |case]] - [lux.compiler.base :as &compiler-base] [lux.compiler :as &compiler] [lux.repl :as &repl] [clojure.string :as string] diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 51b5b4028..614bc0a34 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -9,7 +9,7 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [host :as &&host] + [jvm :as &&jvm] [module :as &&module] [parser :as &&a-parser]))) @@ -130,7 +130,7 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args))) + (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args))) "_lux_:" (|let [(&/$Cons ?type diff --git a/luxc/src/lux/analyser/host.clj b/luxc/src/lux/analyser/host.clj deleted file mode 100644 index d89de457b..000000000 --- a/luxc/src/lux/analyser/host.clj +++ /dev/null @@ -1,1360 +0,0 @@ -(ns lux.analyser.host - (:require (clojure [template :refer [do-template]] - [string :as string]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type] - [host :as &host] - [lexer :as &lexer] - [parser :as &parser] - [reader :as &reader]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &&] - [lambda :as &&lambda] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn ^:private ensure-catching [exceptions*] - "(-> (List Text) (Lux Null))" - (|do [class-loader &/loader] - (fn [state] - (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) - catching (->> state - (&/get$ &/$host) - (&/get$ &/$catching) - (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev ^Class now] - (or prev - (cond (or (.isAssignableFrom java.lang.RuntimeException now) - (.isAssignableFrom java.lang.Error now)) - nil - - (&/fold (fn [found? ^Class ex-catch] - (or found? - (.isAssignableFrom ex-catch now))) - false - catching) - nil - - :else - now))) - nil - exceptions)] - ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) - state) - (&/return* state nil))) - ))) - -(defn ^:private with-catches [catches body] - "(All [a] (-> (List Text) (Lux a) (Lux a)))" - (fn [state] - (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] - (|case (&/run-state body state*) - (&/$Left msg) - (&/$Left msg) - - (&/$Right state** output) - (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) - output])))) - )) - -(defn ^:private ensure-object [type] - "(-> Type (Lux (, Text (List Type))))" - (|case type - (&/$HostT payload) - (return payload) - - (&/$VarT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$ExT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$NamedT _ type*) - (ensure-object type*) - - (&/$UnivQ _ type*) - (ensure-object type*) - - (&/$ExQ _ type*) - (ensure-object type*) - - (&/$AppT F A) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) - -(defn ^:private as-object [type] - "(-> Type Type)" - (|case type - (&/$HostT class params) - (&/$HostT (&host-type/as-obj class) params) - - _ - type)) - -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - -(defn ^:private as-otype+ [type] - "(-> Type Type)" - (|case type - (&/$HostT name params) - (&/$HostT (as-otype name) params) - - _ - type)) - -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/$Cons real-type types)])))) - (&/T [1 &/$Nil]) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&/$UnivQ &type/empty-env base-type) - - _ - base-type)) - (&/$HostT class-name type-args) - type-args)) - -;; [Resources] -(defn ^:private analyse-field-access-helper [obj-type gvars gtype] - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - (|case obj-type - (&/$HostT class targs) - (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - gvars - targs)] - (&host-type/instance-param &type/existential gtype-env gtype)) - (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) - -(defn generic-class->simple-class [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar var-name) - "java.lang.Object" - - (&/$GenericWildcard _) - "java.lang.Object" - - (&/$GenericClass name params) - name - - (&/$GenericArray param) - (|case param - (&/$GenericArray _) - (str "[" (generic-class->simple-class param)) - - (&/$GenericClass "boolean" _) - "[Z" - - (&/$GenericClass "byte" _) - "[B" - - (&/$GenericClass "short" _) - "[S" - - (&/$GenericClass "int" _) - "[I" - - (&/$GenericClass "long" _) - "[J" - - (&/$GenericClass "float" _) - "[F" - - (&/$GenericClass "double" _) - "[D" - - (&/$GenericClass "char" _) - "[C" - - (&/$GenericClass name params) - (str "[L" name ";") - - (&/$GenericTypeVar var-name) - "[Ljava.lang.Object;" - - (&/$GenericWildcard _) - "[Ljava.lang.Object;") - )) - -(defn generic-class->type [env gclass] - "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" - (|case gclass - (&/$GenericTypeVar var-name) - (if-let [ex (&/|get var-name env)] - (return ex) - (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) - - (&/$GenericClass name params) - (case name - "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) - "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) - "short" (return (&/$HostT "java.lang.Short" &/$Nil)) - "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) - "long" (return (&/$HostT "java.lang.Long" &/$Nil)) - "float" (return (&/$HostT "java.lang.Float" &/$Nil)) - "double" (return (&/$HostT "java.lang.Double" &/$Nil)) - "char" (return (&/$HostT "java.lang.Character" &/$Nil)) - "void" (return &/$UnitT) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$HostT name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) - - (&/$GenericWildcard _) - (return (&/$ExQ &/$Nil (&/$BoundT 1))) - )) - -(defn gen-super-env [class-env supers class-decl] - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - (|let [[class-name class-vars] class-decl] - (|case (&/|some (fn [super] - (|let [[super-name super-params] super] - (if (= class-name super-name) - (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) - &/$None))) - supers) - (&/$None) - (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) - - (&/$Some vars+gtypes) - (&/map% (fn [var+gtype] - (|do [:let [[var gtype] var+gtype] - =gtype (generic-class->type class-env gtype)] - (return (&/T [var =gtype])))) - vars+gtypes) - ))) - -(defn ^:private make-type-env [type-params] - "(-> (List TypeParam) (Lux (List [Text Type])))" - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn ^:private double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn ^:private method-input-folder [full-env] - (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (if (double-register-gclass? itype*) - (&&env/with-local iname itype - (&&env/with-local "" &/$VoidT - body*)) - (&&env/with-local iname itype - body*))))) - -(defn ^:private analyse-method [analyse class-decl class-env all-supers method] - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - (|let [[?cname ?cparams] class-decl - class-type (&/$HostT ?cname (&/|map &/|second class-env))] - (|case method - (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - :let [output-type &/$UnitT] - =ctor-args (&/map% (fn [ctor-arg] - (|do [:let [[ca-type ca-term] ctor-arg] - =ca-type (generic-class->type full-env ca-type) - =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T [ca-type =ca-term])))) - ?ctor-args) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - - (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (make-type-env ?gvars) - :let [full-env (&/|++ super-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env method-env] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs)))))] - (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - - (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - ))) - -(defn ^:private mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn ^:private check-method-completion [supers methods] - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - (|do [abstract-methods (mandatory-methods supers) - :let [methods-map (&/fold (fn [mmap mentry] - (|case mentry - (&/$ConstructorMethodAnalysis _) - mmap - - (&/$VirtualMethodAnalysis _) - mmap - - (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) - - (&/$StaticMethodAnalysis _) - mmap - - (&/$AbstractMethodSyntax _) - mmap - - (&/$NativeMethodSyntax _) - mmap - )) - {} - methods) - missing-method (&/fold (fn [missing abs-meth] - (or missing - (|let [[am-name am-inputs] abs-meth] - (if-let [meth-struct (get methods-map am-name)] - (if (some (fn [=inputs] - (and (= (&/|length =inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] - (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) - true - =inputs am-inputs))) - meth-struct) - nil - abs-meth) - abs-meth)))) - nil - abstract-methods)]] - (if (nil? missing-method) - (return nil) - (|let [[am-name am-inputs] missing-method] - (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) - -(defn ^:private analyse-field [analyse gtype-env field] - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) - =value (&&/analyse-1 analyse =gtype ?value)] - (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) - - (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) - (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) - )) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type _?value] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) - - ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" - ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" - ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" - - ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" - ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" - ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" - - ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" - ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" - ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" - ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" - ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" - - ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" - ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" - ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" - ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" - ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" - - ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" - ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" - ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" - ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" - - ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" - - ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] - =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) - =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) - - ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [ ] - (let [input-type (&/$HostT &/$Nil) - output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse input-type x) - =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) - - ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" - - ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" - - ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" - - ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" - - ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" - ) - -(let [length-type &type/Nat - idx-type &type/Nat] - (do-template [ ] - (let [elem-type (&/$HostT &/$Nil) - array-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn ^:private array-class? [class-name] - (or (= &host-type/array-data-tag class-name) - (case class-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true - ;; else - false))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] - gclass (&reader/with-source "jvm-anewarray" _gclass - &&a-parser/parse-gclass) - gtype-env &/get-type-env - =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type inner-arr-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse inner-arr-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Nil)) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn ^:private analyse-jvm-null? [analyse exo-type ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) - -(defn ^:private analyse-jvm-null [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-synchronized [analyse exo-type ?values] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - =expr (&&/analyse-1 analyse exo-type ?expr) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(defn ^:private analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _ (ensure-catching (&/|list throw-class)) - _cursor &/cursor - _ (&type/check exo-type &type/Bottom)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Nil) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - =type (&host-type/instance-param &type/existential &/$Nil gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Nil)) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader !class! field) - =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons value (&/$Nil)) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential &/$Nil gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - :let [obj-type (&&/expr-type* =object)] - _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (analyse-field-access-helper obj-type gvars gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret) - _ (&type/check exo-type (as-otype+ =gret))] - (return (&/T [=gret =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [(&/$VarT _id) $var - gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] - (do-template [ ] - (defn [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object args) ?values] - class-loader &/loader - _ (try (assert! (let [=class (Class/forName !class! true class-loader)] - (= (.isInterface =class))) - (if - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) - [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader !class! method classes)) - _ (ensure-catching exceptions) - =object (&&/analyse-1+ analyse object) - [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) - - ^:private analyse-jvm-invokevirtual "invokevirtual" false - ^:private analyse-jvm-invokespecial "invokespecial" false - ^:private analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) - _ (ensure-catching exceptions) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) - _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn ^:private analyse-jvm-try [analyse exo-type ?values] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] - =body (with-catches (&/|list "java.lang.Exception") - (&&/analyse-1 analyse exo-type ?body)) - =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) - -(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] - ^ClassLoader class-loader &/loader - _ (try (do (.loadClass class-loader _class-name) - (return nil)) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) - :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-interface interface-decl supers =anns =methods) - :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list))))))) - -(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Cons super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) - _ &/pop-dummy-name - :let [_ (println 'CLASS full-name)] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list)))))))) - -(defn ^:private captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$TupleS &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [module &/get-module-name - scope &/get-scope-name - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - anon-class-type (&/$HostT anon-class &/$Nil)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Cons default-) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) - :let [all-supers (&/$Cons super-class interfaces) - class-env &/$Nil] - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars - :let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$Nil - captured-slot-type))) - (&/enumerate =captured))] - :let [sources (&/|map captured-source =captured)] - _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) - _ &/pop-dummy-name - _cursor &/cursor] - (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) - ))) - )))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Nat mask) - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - - ^:private analyse-bit-and "and" - ^:private analyse-bit-or "or" - ^:private analyse-bit-xor "xor" - ) - -(defn ^:private analyse-bit-count [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse input) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat - ) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - ) - -(defn ^:private analyse-deg-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor - (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ) - -(defn analyse-host [analyse exo-type compilers category proc ?values] - (|let [[_ _ compile-class compile-interface] compilers] - (case category - "lux" - (case proc - "==" (analyse-lux-== analyse exo-type ?values)) - - "bit" - (case proc - "count" (analyse-bit-count analyse exo-type ?values) - "and" (analyse-bit-and analyse exo-type ?values) - "or" (analyse-bit-or analyse exo-type ?values) - "xor" (analyse-bit-xor analyse exo-type ?values) - "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - "array" - (case proc - "new" (analyse-array-new analyse exo-type ?values) - "get" (analyse-array-get analyse exo-type ?values) - "put" (analyse-jvm-aastore analyse exo-type ?values) - "remove" (analyse-array-remove analyse exo-type ?values) - "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - "encode" (analyse-deg-encode analyse exo-type ?values) - "decode" (analyse-deg-decode analyse exo-type ?values) - "min-value" (analyse-deg-min-value analyse exo-type ?values) - "max-value" (analyse-deg-max-value analyse exo-type ?values) - "to-real" (analyse-deg-to-real analyse exo-type ?values) - "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "int" - (case proc - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "real" - (case proc - "to-deg" (analyse-real-to-deg analyse exo-type ?values) - ) - - "char" - (case proc - "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ) - - "jvm" - (case proc - "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) - "load-class" (analyse-jvm-load-class analyse exo-type ?values) - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "l2s" (analyse-jvm-l2s analyse exo-type ?values) - "l2b" (analyse-jvm-l2b analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - "b2l" (analyse-jvm-b2l analyse exo-type ?values) - "s2l" (analyse-jvm-s2l analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) - - (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) - - (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) - - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj new file mode 100644 index 000000000..24d2b2017 --- /dev/null +++ b/luxc/src/lux/analyser/jvm.clj @@ -0,0 +1,1360 @@ +(ns lux.analyser.jvm + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.jvm.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn ^:private ensure-catching [exceptions*] + "(-> (List Text) (Lux Null))" + (|do [class-loader &/loader] + (fn [state] + (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) + catching (->> state + (&/get$ &/$host) + (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (cond (or (.isAssignableFrom java.lang.RuntimeException now) + (.isAssignableFrom java.lang.Error now)) + nil + + (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + + :else + now))) + nil + exceptions)] + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (|case (&/run-state body state*) + (&/$Left msg) + (&/$Left msg) + + (&/$Right state** output) + (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output])))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$HostT payload) + (return payload) + + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$AppT F A) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (|case type + (&/$HostT class params) + (&/$HostT (&host-type/as-obj class) params) + + _ + type)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$HostT name params) + (&/$HostT (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$HostT class-name type-args) + type-args)) + +;; [Resources] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$HostT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) + "short" (return (&/$HostT "java.lang.Short" &/$Nil)) + "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) + "long" (return (&/$HostT "java.lang.Long" &/$Nil)) + "float" (return (&/$HostT "java.lang.Float" &/$Nil)) + "double" (return (&/$HostT "java.lang.Double" &/$Nil)) + "char" (return (&/$HostT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$HostT name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) + )) + +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/$HostT ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &/$UnitT] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn ^:private analyse-field [analyse gtype-env field] + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) + + ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" + ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" + ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" + + ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" + ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" + ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" + + ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" + ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" + ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" + ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" + ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" + + ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" + ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" + ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" + ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" + ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" + + ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" + ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" + ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" + ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" + + ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" + + ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) + + ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [ ] + (let [input-type (&/$HostT &/$Nil) + output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) + + ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" + + ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" + + ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" + + ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" + + ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [ ] + (let [elem-type (&/$HostT &/$Nil) + array-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn ^:private array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn ^:private analyse-jvm-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) + +(defn ^:private analyse-jvm-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(defn ^:private analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _ (ensure-catching (&/|list throw-class)) + _cursor &/cursor + _ (&type/check exo-type &type/Bottom)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$VarT _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] + (do-template [ ] + (defn [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= (.isInterface =class))) + (if + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn ^:private analyse-jvm-try [analyse exo-type ?values] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] + =body (with-catches (&/|list "java.lang.Exception") + (&&/analyse-1 analyse exo-type ?body)) + =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) + +(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) + array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] + gtype-env &/get-type-env + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-array-get [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-array-remove [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor + :let [=elem (&&/|meta inner-arr-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] + _ (&type/check exo-type array-type)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) + +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name + :let [_ (println 'CLASS full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) + ))) + )))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + + ^:private analyse-bit-and "and" + ^:private analyse-bit-or "or" + ^:private analyse-bit-xor "xor" + ) + +(defn ^:private analyse-bit-count [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse input) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat + ) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg + ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg + ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg + ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg + ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg + ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool + ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + ) + +(defn ^:private analyse-deg-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Deg x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Deg) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Deg _cursor + (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ) + +(defn analyse-host [analyse exo-type compilers category proc ?values] + (|let [[_ _ compile-class compile-interface] compilers] + (case category + "lux" + (case proc + "==" (analyse-lux-== analyse exo-type ?values)) + + "bit" + (case proc + "count" (analyse-bit-count analyse exo-type ?values) + "and" (analyse-bit-and analyse exo-type ?values) + "or" (analyse-bit-or analyse exo-type ?values) + "xor" (analyse-bit-xor analyse exo-type ?values) + "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-jvm-aastore analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "deg" + (case proc + "+" (analyse-deg-add analyse exo-type ?values) + "-" (analyse-deg-sub analyse exo-type ?values) + "*" (analyse-deg-mul analyse exo-type ?values) + "/" (analyse-deg-div analyse exo-type ?values) + "%" (analyse-deg-rem analyse exo-type ?values) + "=" (analyse-deg-eq analyse exo-type ?values) + "<" (analyse-deg-lt analyse exo-type ?values) + "encode" (analyse-deg-encode analyse exo-type ?values) + "decode" (analyse-deg-decode analyse exo-type ?values) + "min-value" (analyse-deg-min-value analyse exo-type ?values) + "max-value" (analyse-deg-max-value analyse exo-type ?values) + "to-real" (analyse-deg-to-real analyse exo-type ?values) + "scale" (analyse-deg-scale analyse exo-type ?values) + ) + + "int" + (case proc + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "real" + (case proc + "to-deg" (analyse-real-to-deg analyse exo-type ?values) + ) + + "char" + (case proc + "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ) + + "jvm" + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj index c6a079cab..3ccb887ff 100644 --- a/luxc/src/lux/analyser/module.clj +++ b/luxc/src/lux/analyser/module.clj @@ -396,3 +396,16 @@ _ (&/fail-with-loc "[Analyser Error] No import meta-data."))) + +(def tag-groups + "(Lux (List [Text (List Text)]))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags exported? _]] + (&/T [name (&/|map (fn [tag] + (|let [[t-prefix t-name] tag] + t-name)) + tags)]))) + (&/get$ $types module))) + )) diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj index 4792a1809..fafb35818 100644 --- a/luxc/src/lux/compiler.clj +++ b/luxc/src/lux/compiler.clj @@ -1,267 +1,35 @@ (ns lux.compiler (:refer-clojure :exclude [compile]) - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &optimizer] - [host :as &host]) - [lux.host.generics :as &host-generics] - [lux.optimizer :as &o] - [lux.analyser.base :as &a] - [lux.analyser.module :as &a-module] - (lux.compiler [base :as &&] - [cache :as &&cache] - [lux :as &&lux] - [host :as &&host] - [case :as &&case] - [lambda :as &&lambda] - [module :as &&module] + (lux [base :as & :refer [|let |do return* return |case]]) + (lux.compiler [core :as &&core] [io :as &&io] - [parallel :as &¶llel]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) + [parallel :as &¶llel] + [jvm :as &&jvm] + ;; [js :as &&js] + ))) -;; [Resources] -(def ^:private !source->last-line (atom nil)) - -(defn compile-expression [$begin syntax] - (|let [[[?type [_file-name _line _]] ?form] syntax] - (|do [^MethodVisitor *writer* &/get-writer - :let [debug-label (new Label) - _ (when (not= _line (get @!source->last-line _file-name)) - (doto *writer* - (.visitLabel debug-label) - (.visitLineNumber (int _line) debug-label)) - (swap! !source->last-line assoc _file-name _line))]] - (|case ?form - (&o/$bool ?value) - (&&lux/compile-bool ?value) - - (&o/$nat ?value) - (&&lux/compile-nat ?value) - - (&o/$int ?value) - (&&lux/compile-int ?value) - - (&o/$deg ?value) - (&&lux/compile-deg ?value) - - (&o/$real ?value) - (&&lux/compile-real ?value) - - (&o/$char ?value) - (&&lux/compile-char ?value) - - (&o/$text ?value) - (&&lux/compile-text ?value) - - (&o/$tuple ?elems) - (&&lux/compile-tuple (partial compile-expression $begin) ?elems) - - (&o/$var (&/$Local ?idx)) - (&&lux/compile-local (partial compile-expression $begin) ?idx) - - (&o/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) - - (&o/$var (&/$Global ?owner-class ?name)) - (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) - - (&o/$apply ?fn ?args) - (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) - - (&o/$loop _register-offset _inits _body) - (&&lux/compile-loop compile-expression _register-offset _inits _body) - - (&o/$iter _register-offset ?args) - (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) - - (&o/$variant ?tag ?tail ?members) - (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) - - (&o/$case ?value [?pm ?bodies]) - (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) - - (&o/$let _value _register _body) - (&&lux/compile-let (partial compile-expression $begin) _value _register _body) - - (&o/$record-get _value _path) - (&&lux/compile-record-get (partial compile-expression $begin) _value _path) - - (&o/$if _test _then _else) - (&&lux/compile-if (partial compile-expression $begin) _test _then _else) - - (&o/$function _register-offset ?arity ?scope ?env ?body) - (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) - - (&o/$ann ?value-ex ?type-ex) - (compile-expression $begin ?value-ex) - - (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) - - _ - (assert false (prn-str 'compile-expression (&/adt->text syntax))) - )) - )) - -(defn init! - "(-> (List Text) Null)" - [resources-dirs ^String target-dir] - (do (reset! &&/!output-dir target-dir) +(defn init! [resources-dirs ^String target-dir] + (do (reset! &&core/!output-dir target-dir) (&¶llel/setup!) (&&io/init-libs!) - (reset! !source->last-line {}) (.mkdirs (new java.io.File target-dir)) - (let [class-loader (ClassLoader/getSystemClassLoader) - addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL])) - (.setAccessible true))] - (doseq [^String resources-dir (&/->seq resources-dirs)] - (.invoke addURL class-loader - (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)])))))) - -(defn eval! [expr] - (&/with-eval - (|do [module &/get-module-name - id &/gen-id - [file-name _ _] &/cursor - :let [class-name (str (&host/->module-class module) "/" id) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile-expression nil expr) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! (str id) bytecode) - loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) - (.getField &/eval-field) - (.get nil) - return)))) + (&&jvm/init! resources-dirs target-dir) + ;; (&&js/init! resources-dirs target-dir) + )) (def all-compilers - (let [compile-expression* (partial compile-expression nil)] - (&/T [(partial &&lux/compile-def compile-expression) - (partial &&lux/compile-program compile-expression*) - (partial &&host/compile-jvm-class compile-expression*) - &&host/compile-jvm-interface]))) + &&jvm/all-compilers) -(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) - +datum-sig+ "Ljava/lang/Object;"] - (defn compile-module [source-dirs name] - (let [file-name (str name ".lux")] - (|do [file-content (&&io/read-file source-dirs file-name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (&&cache/load name) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc "[Compiler Error] Can't redefine a module!") - (|do [_ (&&cache/delete name) - _ (&a-module/create-module name file-hash) - _ (&/flag-active-module name) - :let [module-class-name (str (&host/->module-class name) "/_") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - module-class-name nil "java/lang/Object" nil) - (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) - .visitEnd) - (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) - .visitEnd) - (.visitSource file-name nil))] - _ (if (= "lux" name) - (|do [_ &&host/compile-Function-class - _ &&host/compile-LuxRT-class] - (return nil)) - (return nil))] - (fn [state] - (|case ((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [:let [_ (.visitEnd =class)] - module-anns (&a-module/get-anns name) - defs &a-module/defs - imports &a-module/imports - tag-groups &&module/tag-groups - :let [def-entries (->> defs - (&/|map (fn [_def] - (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] - (if (= "" ?alias) - (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns)) - (str ?name &&/datum-separator ?alias))))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - import-entries (->> imports - (&/|map (fn [import] - (|let [[_module _hash] import] - (str _module &&/datum-separator _hash)))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - tag-entries (->> tag-groups - (&/|map (fn [group] - (|let [[type tags] group] - (->> tags - (&/|interpose &&/datum-separator) - (&/fold str "") - (str type &&/datum-separator))))) - (&/|interpose &&/entry-separator) - (&/fold str "")) - module-descriptor (->> (&/|list import-entries - tag-entries - (&&&ann/serialize-anns module-anns) - def-entries) - (&/|interpose &&/section-separator) - (&/fold str ""))] - _ (&/flag-compiled-module name) - _ (&&/save-class! &/module-class-name (.toByteArray =class)) - _ (&&/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message)))))))) - ) - ))) +(defn eval! [expr] + (&&jvm/eval! expr)) -(let [!err! *err*] - (defn compile-program [mode program-module resources-dir source-dirs target-dir] - (do (init! resources-dir target-dir) - (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs) - _ (compile-module source-dirs "lux")] - (compile-module source-dirs program-module))] - (|case (m-action (&/init-state mode)) - (&/$Right ?state _) - (do (println "Compilation complete!") - (&&cache/clean ?state)) +(defn compile-module [source-dirs name] + (&&jvm/compile-module source-dirs name)) - (&/$Left ?message) - (binding [*out* !err!] - (do (println (str "Compilation failed:\n" ?message)) - (flush) - (System/exit 1)))))))) +(defn compile-program [mode program-module resources-dir source-dirs target-dir] + (init! resources-dir target-dir) + (&&jvm/compile-program mode program-module resources-dir source-dirs target-dir) + ;; (&&js/compile-program mode program-module resources-dir source-dirs target-dir) + ) diff --git a/luxc/src/lux/compiler/base.clj b/luxc/src/lux/compiler/base.clj deleted file mode 100644 index e57fc1e2b..000000000 --- a/luxc/src/lux/compiler/base.clj +++ /dev/null @@ -1,112 +0,0 @@ -(ns lux.compiler.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail*]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - [lux.host.generics :as &host-generics]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Constants] -(def !output-dir (atom nil)) - -(def ^:const ^String function-class "lux/Function") -(def ^:const ^String lux-utils-class "lux/LuxRT") -(def ^:const ^String unit-tag-field "unit_tag") - -;; Formats -(def ^:const ^String local-prefix "l") -(def ^:const ^String partial-prefix "p") -(def ^:const ^String closure-prefix "c") -(def ^:const ^String apply-method "apply") -(defn ^String apply-signature [n] - (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) -(def ^:const num-apply-variants 8) -(def ^:const arity-field "_arity_") -(def ^:const partials-field "_partials_") - -(def ^:const section-separator (->> 29 char str)) -(def ^:const datum-separator (->> 31 char str)) -(def ^:const entry-separator (->> 30 char str)) - -;; [Utils] -(defn ^:private write-file [^String file-name ^bytes data] - (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) - (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] - (.write stream data) - (.flush stream)))) - -(defn ^:private write-output [module name data] - (let [^String module* (&host/->module-class module) - module-dir (str @!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] - (.mkdirs (File. module-dir)) - (write-file (str module-dir java.io.File/separator name ".class") data))) - -(defn class-exists? [^String module ^String class-name] - "(-> Text Text (IO Bool))" - (|do [_ (return nil) - :let [full-path (str @!output-dir java.io.File/separator module java.io.File/separator class-name ".class") - exists? (.exists (File. full-path))]] - (return exists?))) - -;; [Exports] -(defn ^Class load-class! [^ClassLoader loader name] - ;; (prn 'load-class! name) - (.loadClass loader name)) - -(defn save-class! [name bytecode] - (|do [eval? &/get-eval - module &/get-module-name - loader &/loader - !classes &/classes - :let [real-name (str (&host-generics/->class-name module) "." name) - _ (swap! !classes assoc real-name bytecode) - _ (when (not eval?) - (write-output module name bytecode)) - _ (load-class! loader real-name)]] - (return nil))) - -(def ^String lux-module-descriptor-name "lux_module_descriptor") - -(defn write-module-descriptor! [^String name ^String descriptor] - (|do [_ (return nil) - :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator)) - _ (.mkdirs (File. lmd-dir)) - _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] - (return nil))) - -(defn read-module-descriptor! [^String name] - (|do [_ (return nil)] - (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) - :encoding "UTF-8")))) - -(do-template [ ] - (do (defn [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))) - (defn [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST ) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) - - wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 - wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 - wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 - wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 - wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 - wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 - wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 - wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 - ) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj deleted file mode 100644 index 8ca319d66..000000000 --- a/luxc/src/lux/compiler/cache.clj +++ /dev/null @@ -1,274 +0,0 @@ -(ns lux.compiler.cache - (:refer-clojure :exclude [load]) - (:require [clojure.string :as string] - [clojure.java.io :as io] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler [base :as &&] - [io :as &&io]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Utils] -(defn ^:private read-file [^File file] - "(-> File (Array Byte))" - (with-open [reader (io/input-stream file)] - (let [length (.length file) - buffer (byte-array length)] - (.read reader buffer 0 length) - buffer))) - -(defn ^:private clean-file [^File file] - "(-> File (,))" - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - -(defn ^:private get-field [^String field-name ^Class class] - "(-> Text Class Object)" - (-> class ^Field (.getField field-name) (.get nil))) - -;; [Resources] -(def module-class-file (str &/module-class-name ".class")) - -(defn cached? [module] - "(-> Text Bool)" - (.exists (new File (str @&&/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator) - java.io.File/separator - module-class-file)))) - -(defn delete [module] - "(-> Text (Lux Null))" - (fn [state] - (do (clean-file (new File (str @&&/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator)))) - (return* state nil)))) - -(defn ^:private module-dirs - "(-> File (clojure.Seq File))" - [^File module] - (->> module - .listFiles - (filter #(.isDirectory ^File %)) - (map module-dirs) - (apply concat) - (list* module))) - -(defn clean [state] - "(-> Compiler Null)" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) - output-dir-prefix (str (.getAbsolutePath (new File ^String @&&/!output-dir)) java.io.File/separator) - outdated? #(->> % (contains? needed-modules) not) - outdated-modules (->> (new File ^String @&&/!output-dir) - .listFiles (filter #(.isDirectory ^File %)) - (map module-dirs) doall (apply concat) - (map (fn [^File dir-file] - (let [^String dir-module (-> dir-file - .getAbsolutePath - (string/replace output-dir-prefix "")) - corrected-dir-module (.replace dir-module java.io.File/separator "/")] - corrected-dir-module))) - (filter outdated?))] - (doseq [^String f outdated-modules] - (clean-file (new File (str output-dir-prefix f)))) - nil)) - -(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] - (let [classes+bytecode (for [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= module-class-file file-name)] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[class-name bytecode] classes+bytecode] - (swap! !classes assoc (str module* "." class-name) bytecode))] - (map first classes+bytecode))) - -(defn ^:private assume-async-result - "(-> (Error Compiler) (Lux Null))" - [result] - (fn [_] - (|case result - (&/$Left error) - (&/$Left error) - - (&/$Right compiler) - (return* compiler nil)))) - -(defn ^:private parse-tag-groups [^String tags-section] - (if (= "" tags-section) - &/$Nil - (-> tags-section - (.split &&/entry-separator) - seq - (->> (map (fn [^String _group] - (let [[_type & _tags] (.split _group &&/datum-separator)] - (&/T [_type (->> _tags seq &/->list)]))))) - &/->list))) - -(defn ^:private process-tag-group [module group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - -(defn ^:private process-def-entry [loader module ^String _def-entry] - (let [parts (.split _def-entry &&/datum-separator)] - (case (alength parts) - 2 (let [[_name _alias] parts - [_ __module __name] (re-find #"^(.*);(.*)$" _alias) - def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) - def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))])) - def-value (get-field &/value-field def-class)] - (|do [def-type (&a-module/def-type __module __name)] - (&a-module/define module _name def-type def-anns def-value))) - 3 (let [[_name _type _anns] parts - def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name _name))) - def-anns (&&&ann/deserialize-anns _anns) - [def-type _] (&&&type/deserialize-type _type) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-anns def-value))))) - -(defn ^:private uninstall-cache [module] - (|do [_ (delete module)] - (return false))) - -(defn ^:private install-module [loader module module-hash imports tag-groups module-anns def-entries] - (|do [_ (&a-module/create-module module module-hash) - _ (&a-module/set-anns module-anns module) - _ (&a-module/set-imports imports) - _ (&/map% (partial process-def-entry loader module) - def-entries) - _ (&/map% (partial process-tag-group module) tag-groups)] - (return nil))) - -(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader] - (|do [^String descriptor (&&/read-module-descriptor! module-name) - :let [[imports-section tags-section module-anns-section defs-section] (.split descriptor &&/section-separator) - imports (let [imports (vec (.split ^String imports-section &&/entry-separator)) - imports (if (= [""] imports) - &/$Nil - (&/->list imports))] - (&/|map #(.split ^String % &&/datum-separator 2) imports))] - cache-table* (&/fold% (fn [cache-table* _import] - (|do [:let [[_module _hash] _import] - file-content (&&io/read-file source-dirs (str _module ".lux")) - output (pre-load! source-dirs cache-table* _module (hash file-content))] - (return output))) - cache-table - imports)] - (if (&/|every? (fn [_import] - (|let [[_module _hash] _import] - (contains? cache-table* _module))) - imports) - (let [tag-groups (parse-tag-groups tags-section) - module-anns (&&&ann/deserialize-anns module-anns-section) - def-entries (let [def-entries (vec (.split ^String defs-section &&/entry-separator))] - (if (= [""] def-entries) - &/$Nil - (&/->list def-entries)))] - (|do [_ (install-module loader module-name module-hash - imports tag-groups module-anns def-entries) - =module (&/find-module module-name)] - (return (&/T [true (assoc cache-table* module-name =module)])))) - (return (&/T [false cache-table*]))))) - -(defn ^:private enumerate-cached-modules!* [^File parent] - (if (.isDirectory parent) - (let [children (for [^File child (seq (.listFiles parent)) - entry (enumerate-cached-modules!* child)] - entry)] - (if (.exists (new File parent "_.class")) - (list* (.getAbsolutePath parent) - children) - children)) - (list))) - -(defn ^:private enumerate-cached-modules! [] - (let [output-dir (new File ^String @&&/!output-dir) - prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] - (->> output-dir - enumerate-cached-modules!* - rest - (map #(-> ^String % - (.replace java.io.File/separator "/") - (.substring prefix-to-subtract))) - &/->list))) - -(defn ^:private pre-load! [source-dirs cache-table module module-hash] - (cond (contains? cache-table module) - (return cache-table) - - (not (cached? module)) - (return cache-table) - - :else - (|do [loader &/loader - !classes &/classes - :let [module* (&host-generics/->class-name module) - module-path (str @&&/!output-dir java.io.File/separator module) - class-name (str module* "." &/module-class-name) - ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) - (&&/load-class! loader class-name)) - installed-classes (install-all-classes-in-module !classes module* module-path) - valid-cache? (and (= module-hash (get-field &/hash-field module-class)) - (= &/compiler-version (get-field &/compiler-field module-class))) - drop-cache! (|do [_ (uninstall-cache module) - :let [_ (swap! !classes (fn [_classes-dict] - (reduce dissoc _classes-dict installed-classes)))]] - (return cache-table))]] - (if valid-cache? - (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module module-hash loader) - _ (if success? - (return nil) - drop-cache!)] - (return cache-table*)) - drop-cache!)))) - -(def !pre-loaded-cache (atom nil)) -(defn pre-load-cache! [source-dirs] - (|do [:let [fs-cached-modules (enumerate-cached-modules!)] - pre-loaded-modules (&/fold% (fn [cache-table module-name] - (fn [_compiler] - (|case ((&&io/read-file source-dirs (str module-name ".lux")) - _compiler) - (&/$Left error) - (return* _compiler cache-table) - - (&/$Right _compiler* file-content) - ((pre-load! source-dirs cache-table module-name (hash file-content)) - _compiler*)))) - {} - fs-cached-modules) - :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] - (return nil))) - -(defn ^:private inject-module - "(-> (Module Compiler) (-> Compiler (Lux Null)))" - [module-name module] - (fn [compiler] - (return* (&/update$ &/$modules - #(&/|put module-name module %) - compiler) - nil))) - -(defn load [module-name] - "(-> Text (Lux Null))" - (if-let [module-struct (get @!pre-loaded-cache module-name)] - (|do [_ (inject-module module-name module-struct) - _ (&/flag-cached-module module-name)] - (return nil)) - (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/compiler/case.clj b/luxc/src/lux/compiler/case.clj deleted file mode 100644 index aac3b6c98..000000000 --- a/luxc/src/lux/compiler/case.clj +++ /dev/null @@ -1,214 +0,0 @@ -(ns lux.compiler.case - (:require (clojure [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.analyser.case :as &a-case] - [lux.compiler.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] - (cond (= 0 stack-depth) - writer - - (= 1 stack-depth) - (doto writer - (.visitInsn Opcodes/POP)) - - (= 2 stack-depth) - (doto writer - (.visitInsn Opcodes/POP2)) - - :else ;; > 2 - (doto writer - (.visitInsn Opcodes/POP2) - (pop-alt-stack (- stack-depth 2))))) - -(defn ^:private stack-peek [^MethodVisitor writer] - (doto writer - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;"))) - -(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] - "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" - (|case pm - (&o/$ExecPM _body-idx) - (|case (&/|at _body-idx bodies) - (&/$Some $body) - (doto writer - (pop-alt-stack stack-depth) - (.visitJumpInsn Opcodes/GOTO $body)) - - (&/$None) - (assert false)) - - (&o/$PopPM) - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) - - (&o/$BindPM _var-id) - (doto writer - stack-peek - (.visitVarInsn Opcodes/ASTORE _var-id) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) - - (&o/$BoolPM _value) - (doto writer - stack-peek - &&/unwrap-boolean - (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) - - (&o/$NatPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$IntPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$DegPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$RealPM _value) - (doto writer - stack-peek - &&/unwrap-double - (.visitLdcInsn (double _value)) - (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$CharPM _value) - (doto writer - stack-peek - &&/unwrap-char - (.visitLdcInsn _value) - (.visitJumpInsn Opcodes/IF_ICMPNE $else)) - - (&o/$TextPM _value) - (doto writer - stack-peek - (.visitLdcInsn _value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else)) - - (&o/$TuplePM _idx+) - (|let [[_idx is-tail?] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true]))] - (if (= 0 _idx) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int _idx)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - ))) - - (&o/$VariantPM _idx+) - (|let [$success (new Label) - $fail (new Label) - [_idx is-last] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true])) - _ (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int _idx))) - _ (if is-last - (.visitLdcInsn writer "") - (.visitInsn writer Opcodes/ACONST_NULL))] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $fail) - (.visitJumpInsn Opcodes/GOTO $success) - (.visitLabel $fail) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $success) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - - (&o/$SeqPM _left-pm _right-pm) - (doto writer - (compile-pattern* bodies stack-depth $else _left-pm) - (compile-pattern* bodies stack-depth $else _right-pm)) - - (&o/$AltPM _left-pm _right-pm) - (|let [$alt-else (new Label)] - (doto writer - (.visitInsn Opcodes/DUP) - (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) - (.visitLabel $alt-else) - (.visitInsn Opcodes/POP) - (compile-pattern* bodies stack-depth $else _right-pm))) - )) - -(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] - (|let [$else (new Label)] - (doto writer - (compile-pattern* bodies 1 $else pm) - (.visitLabel $else) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") - (.visitInsn Opcodes/ACONST_NULL) - (.visitJumpInsn Opcodes/GOTO $end)))) - -(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] - (&/map% (fn [label+body] - (|let [[_label _body] label+body] - (|do [:let [_ (.visitLabel writer _label)] - _ (compile _body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return nil)))) - (&/zip2 bodies-labels ?bodies))) - -;; [Resources] -(defn compile-case [compile ?value ?pm ?bodies] - (|do [^MethodVisitor *writer* &/get-writer - :let [$end (new Label) - bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] - _ (compile ?value) - :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - _ (compile-pattern *writer* bodies-labels ?pm $end)] - _ (compile-bodies *writer* compile bodies-labels ?bodies $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj new file mode 100644 index 000000000..4779c3c28 --- /dev/null +++ b/luxc/src/lux/compiler/core.clj @@ -0,0 +1,82 @@ +(ns lux.compiler.core + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File + BufferedOutputStream + FileOutputStream))) + +;; [Constants] +(def !output-dir (atom nil)) + +(def ^:const section-separator (->> 29 char str)) +(def ^:const datum-separator (->> 31 char str)) +(def ^:const entry-separator (->> 30 char str)) + +;; [Utils] +(defn write-file [^String file-name ^bytes data] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data) + (.flush stream)))) + +;; [Exports] +(def ^String lux-module-descriptor-name "lux_module_descriptor") + +(defn write-module-descriptor! [^String name ^String descriptor] + (|do [_ (return nil) + :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator)) + _ (.mkdirs (File. lmd-dir)) + _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] + (return nil))) + +(defn read-module-descriptor! [^String name] + (|do [_ (return nil)] + (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) + :encoding "UTF-8")))) + +(def generate-module-descriptor + (|do [module-name &/get-module-name + module-anns (&a-module/get-anns module-name) + defs &a-module/defs + imports &a-module/imports + tag-groups &a-module/tag-groups + :let [def-entries (->> defs + (&/|map (fn [_def] + (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def] + (if (= "" ?alias) + (str ?name datum-separator (&&&type/serialize-type ?def-type) datum-separator (&&&ann/serialize-anns ?def-anns)) + (str ?name datum-separator ?alias))))) + (&/|interpose entry-separator) + (&/fold str "")) + import-entries (->> imports + (&/|map (fn [import] + (|let [[_module _hash] import] + (str _module datum-separator _hash)))) + (&/|interpose entry-separator) + (&/fold str "")) + tag-entries (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags + (&/|interpose datum-separator) + (&/fold str "") + (str type datum-separator))))) + (&/|interpose entry-separator) + (&/fold str "")) + module-descriptor (->> (&/|list import-entries + tag-entries + (&&&ann/serialize-anns module-anns) + def-entries) + (&/|interpose section-separator) + (&/fold str ""))]] + (return module-descriptor))) diff --git a/luxc/src/lux/compiler/host.clj b/luxc/src/lux/compiler/host.clj deleted file mode 100644 index f0249f3d3..000000000 --- a/luxc/src/lux/compiler/host.clj +++ /dev/null @@ -1,2762 +0,0 @@ -(ns lux.compiler.host - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - [lux.compiler.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "") - -(let [class+method+sig {"boolean" &&/unwrap-boolean - "byte" &&/unwrap-byte - "short" &&/unwrap-short - "int" &&/unwrap-int - "long" &&/unwrap-long - "float" &&/unwrap-float - "double" &&/unwrap-double - "char" &&/unwrap-char}] - (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] - (if-let [unwrap (get class+method+sig class-name)] - (doto *writer* - unwrap) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) - -(let [boolean-class "java.lang.Boolean" - byte-class "java.lang.Byte" - short-class "java.lang.Short" - int-class "java.lang.Integer" - long-class "java.lang.Long" - float-class "java.lang.Float" - double-class "java.lang.Double" - char-class "java.lang.Character"] - (defn prepare-return! [^MethodVisitor *writer* *type*] - (|case *type* - (&/$UnitT) - (.visitLdcInsn *writer* &/unit-tag) - - (&/$HostT "boolean" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) - - (&/$HostT "byte" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) - - (&/$HostT "short" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) - - (&/$HostT "int" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) - - (&/$HostT "long" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) - - (&/$HostT "float" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) - - (&/$HostT "double" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) - - (&/$HostT "char" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) - - (&/$HostT _ _) - nil - - (&/$NamedT ?name ?type) - (prepare-return! *writer* ?type) - - (&/$ExT _) - nil - - _ - (assert false (str 'prepare-return! " " (&type/show-type *type*)))) - *writer*)) - -;; [Resources] -(defn ^:private compile-annotation [writer ann] - (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) - nil) - -(defn ^:private compile-field [^ClassWriter writer field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|let [=field (.visitField writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) - ?name - (&host-generics/gclass->simple-signature ?gclass) - (&host-generics/gclass->signature ?gclass) nil)] - (do (&/|map (partial compile-annotation =field) ?anns) - (.visitEnd =field) - nil)) - - (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) - (|let [=field (.visitField writer - (+ (&host/privacy-modifier->flag =privacy-modifier) - (&host/state-modifier->flag =state-modifier)) - =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) nil)] - (do (&/|map (partial compile-annotation =field) =anns) - (.visitEnd =field) - nil)) - )) - -(defn ^:private compile-method-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$Nil)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$Nil)) - (doto writer - &&/unwrap-boolean - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$Nil)) - (doto writer - &&/unwrap-byte - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$Nil)) - (doto writer - &&/unwrap-short - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$Nil)) - (doto writer - &&/unwrap-int - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$Nil)) - (doto writer - &&/unwrap-long - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$Nil)) - (doto writer - &&/unwrap-float - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$Nil)) - (doto writer - &&/unwrap-double - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$Nil)) - (doto writer - &&/unwrap-char - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass _class-name (&/$Nil)) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) - (.visitInsn Opcodes/ARETURN)) - - _ - (.visitInsn writer Opcodes/ARETURN))) - -(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] - "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" - (|case input - [_ (&/$GenericClass name params)] - (case name - "boolean" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-boolean - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) - "byte" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-byte - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) - "short" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-short - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) - "int" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-int - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) - "long" (do (doto method-visitor - (.visitVarInsn Opcodes/LLOAD idx) - &&/wrap-long - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) - "float" (do (doto method-visitor - (.visitVarInsn Opcodes/FLOAD idx) - &&/wrap-float - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) - "double" (do (doto method-visitor - (.visitVarInsn Opcodes/DLOAD idx) - &&/wrap-double - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) - "char" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-char - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) - ;; else - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) - - [_ gclass] - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) - )) - -(defn ^:private prepare-method-inputs [idx inputs method-visitor] - "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" - (|case inputs - (&/$Nil) - (return &/$Nil) - - (&/$Cons input inputs*) - (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] - (|do [:let [[_idx _outputs] idx+outputs] - [idx* output] (prepare-method-input _idx input method-visitor)] - (return (&/T [idx* (&/$Cons output _outputs)])))) - (&/T [idx &/$Nil]) - inputs)] - (return (&/list-join (&/|reverse outputs*)))) - )) - -(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] - (|case method-def - (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|let [?output (&/$GenericClass "void" (&/|list)) - =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0)) - init-method - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [[super-class-name super-class-params] ?super-class - init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) - init-sig (str "(" init-types ")" "V") - _ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] - _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) - :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if =final? Opcodes/ACC_FINAL 0) - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0) - Opcodes/ACC_STATIC) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 0 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_ABSTRACT - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - - (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - )) - -(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) - =method (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - _ (&/|map (partial compile-annotation =method) =anns) - _ (.visitEnd =method)] - nil)) - -(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] - (case type - "boolean" (doto writer - &&/unwrap-boolean) - "byte" (doto writer - &&/unwrap-byte) - "short" (doto writer - &&/unwrap-short) - "int" (doto writer - &&/unwrap-int) - "long" (doto writer - &&/unwrap-long) - "float" (doto writer - &&/unwrap-float) - "double" (doto writer - &&/unwrap-double) - "char" (doto writer - &&/unwrap-char) - ;; else - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) - -(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") - -return "V"] - (defn ^:private anon-class--signature [env] - (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" - -return)) - - (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] - (|let [[super-class-name super-class-params] super-class - init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] - (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0))] - _ (&/map% (fn [type+term] - (|let [[type term] type+term] - (|do [_ (compile term) - :let [_ (prepare-ctor-arg =method type)]] - (return nil)))) - ctor-args) - :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq env)]))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ) - -(defn ^:private constant-inits [fields] - "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" - (&/fold &/|++ - &/$Nil - (&/|map (fn [field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (&/|list (&/T [?name ?gclass ?value])) - - (&/$VariableFieldSyntax _) - (&/|list) - )) - fields))) - -(declare compile-jvm-putstatic) -(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] - (|do [module &/get-module-name - [file-name line column] &/cursor - :let [[?name ?params] class-decl - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) - full-name (str module "/" ?name) - super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - (&host/inheritance-modifier->flag ?inheritance-modifier)) - full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =class) ?anns) - _ (&/|map (partial compile-field =class) - ?fields)] - _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) - _ (|case ??ctor-args - (&/$Some ctor-args) - (add-anon-class- =class compile full-name ?super-class env ctor-args) - - _ - (return nil)) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode))] - _ (&/map% (fn [ftriple] - (|let [[fname fgclass fvalue] ftriple] - (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) - (constant-inits ?fields)) - :let [_ (doto =method - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) - -(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] - (|do [:let [[interface-name interface-vars] interface-decl] - module &/get-module-name - [file-name _ _] &/cursor - :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) - (str module "/" interface-name) - (if (= "" interface-signature) nil interface-signature) - "java/lang/Object" - (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =interface) ?anns) - _ (do (&/|map (partial compile-method-decl =interface) ?methods) - (.visitEnd =interface))]] - (&&/save-class! interface-name (.toByteArray =interface)))) - -(def compile-Function-class - (|do [_ (return nil) - :let [super-class "java/lang/Object" - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - Opcodes/ACC_ABSTRACT - ;; Opcodes/ACC_INTERFACE - ) - &&/function-class nil super-class (into-array String [])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) - (doto (.visitEnd)))) - =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (dotimes [arity* &&/num-apply-variants] - (let [arity (inc arity*)] - (if (= 1 arity) - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) - (.visitEnd)) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) - (.visitCode) - (-> (.visitVarInsn Opcodes/ALOAD idx) - (->> (dotimes [idx arity]))) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD arity) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))))]] - (&&/save-class! (second (string/split &&/function-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] - (|let [_ (let [$begin (new Label) - $not-rec (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size - (.visitInsn Opcodes/ISUB) ;; sub-index - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple - (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size - (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem - (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $is-last (new Label) - $must-copy (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; - ;; Must recurse - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size - (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem - (.visitInsn Opcodes/AALOAD) ;; tuple-tail - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size - (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* - (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail - (.visitVarInsn Opcodes/ASTORE 0) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $must-copy) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $is-last) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $just-return (new Label) - $then (new Label) - $further (new Label) - $not-right (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ILOAD 1) ;; tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum - (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' - &&/unwrap-int ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $then) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? - (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) - (.visitJumpInsn Opcodes/GOTO $further) - (.visitLabel $just-return) - (.visitInsn Opcodes/POP2) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $further) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum - (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? - (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/ISUB) ;; sub-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum - (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx - (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; I commented-out some parts because a null-check was - ;; done to ensure variants were never created with null - ;; values (this would interfere later with - ;; pattern-matching). - ;; Since Lux itself doesn't have null values as part of - ;; the language, the burden of ensuring non-nulls was - ;; shifted to library code dealing with host-interop, to - ;; ensure variant-making was as fast as possible. - ;; The null-checking code was left as comments in case I - ;; ever change my mind. - _ (let [;; $is-null (new Label) - ] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - ;; (.visitVarInsn Opcodes/ALOAD 2) - ;; (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 3)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ILOAD 0) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - ;; (.visitLabel $is-null) - ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - ;; (.visitInsn Opcodes/DUP) - ;; (.visitLdcInsn "Can't create variant for null pointer") - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - ;; (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)))] - nil)) - -(defn ^:private low-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. - (.visitLdcInsn (int -1)) - (.visitInsn Opcodes/I2L) - ;; Then do a bitwise and. - (.visitInsn Opcodes/LAND) - )) - -(defn ^:private high-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - )) - -(defn ^:private swap2 [^MethodVisitor =method] - (doto =method - ;; X2, Y2 - (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X2 - )) - -(defn ^:private swap2x1 [^MethodVisitor =method] - (doto =method - ;; X1, Y2 - (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X1 - )) - -(defn ^:private bit-set-64? [^MethodVisitor =method] - (doto =method - ;; L, I - (.visitLdcInsn (long 1)) ;; L, I, L - (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L - (.visitInsn Opcodes/POP2) ;; L, L, I - (.visitInsn Opcodes/LSHL) ;; L, L - (.visitInsn Opcodes/LAND) ;; L - (.visitLdcInsn (long 0)) ;; L, L - (.visitInsn Opcodes/LCMP) ;; I - )) - -(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] - (|let [deg-bits 64 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) - ;; Based on: http://stackoverflow.com/a/31629280/6823464 - (.visitCode) - ;; Bottom part - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Middle part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) - ;; Join middle and bottom - (.visitInsn Opcodes/LADD) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Top part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - ;; Join top with rest - (.visitInsn Opcodes/LADD) - ;; Return - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) - (.visitCode) - ;; Based on: http://stackoverflow.com/a/8510587/6823464 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LDIV) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) - (.visitCode) - ;; Translate high bytes - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Translate low bytes - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Combine and return - (.visitInsn Opcodes/DADD) - (.visitInsn Opcodes/DRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) - (.visitCode) - ;; Drop any excess - (.visitVarInsn Opcodes/DLOAD 0) - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - ;; Shift upper half, but retain remaining decimals - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Make a copy, so the lower half can be extracted - (.visitInsn Opcodes/DUP2) - ;; Get that lower half - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Turn it into a deg - (.visitInsn Opcodes/D2L) - ;; Turn the upper half into deg too - swap2 - (.visitInsn Opcodes/D2L) - ;; Combine both pieces - (.visitInsn Opcodes/LADD) - ;; FINISH - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int 0)) ;; {carry} - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} - (.visitLdcInsn (int 5)) - (.visitInsn Opcodes/IMUL) - (.visitInsn Opcodes/IADD) ;; {next-raw-digit} - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 0) - swap2x1 - (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IDIV) ;; {next-carry} - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 0) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) - (.visitCode) - ;; Initialize digits array. - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} - (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 - (.visitVarInsn Opcodes/ASTORE 1) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitVarInsn Opcodes/ILOAD 0) ;; {times} - (.visitLabel $loop-start) - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - ;; {times} - (.visitVarInsn Opcodes/ILOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} - (.visitVarInsn Opcodes/ASTORE 1) ;; {times} - ;; Decrement index - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - ;; {times-1} - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits - (.visitLdcInsn (int 0)) ;; {carry} - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - ;; {carry} - (.visitVarInsn Opcodes/ALOAD 3) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {carry, dL} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} - (.visitInsn Opcodes/IADD) - (.visitInsn Opcodes/IADD) ;; {raw-next-digit} - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} - (.visitVarInsn Opcodes/ALOAD 3) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IDIV) ;; {next-carry} - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn "") ;; {text} - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitInsn Opcodes/BALOAD) ;; {text, digit} - (.visitLdcInsn (int 10)) ;; {text, digit, radix} - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $not-set (new Label) - $next-iteration (new Label) - $normal-path (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - ;; A quick corner-case to handle. - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $normal-path) - (.visitLdcInsn ".0") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $normal-path) - ;; Normal case - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 3) ;; digits - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - ;; Prepare text to return. - (.visitVarInsn Opcodes/ALOAD 3) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") - (.visitLdcInsn ".") - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - ;; Trim unnecessary 0s at the end... - (.visitLdcInsn "0*$") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - bit-set-64? - (.visitJumpInsn Opcodes/IFEQ $next-iteration) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") - (.visitVarInsn Opcodes/ALOAD 3) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") - (.visitVarInsn Opcodes/ASTORE 3) - (.visitJumpInsn Opcodes/GOTO $next-iteration) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $next-iteration) - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $not-set (new Label) - $next-iteration (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 2) ;; digits - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") - ;; Set digit - (.visitVarInsn Opcodes/ALOAD 2) - (.visitVarInsn Opcodes/ILOAD 1) - swap2x1 - (.visitInsn Opcodes/BASTORE) - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $is-less-than (new Label) - $is-equal (new Label)] - ;; [B0 <= [B1 - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) - (.visitCode) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int deg-bits)) - (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) - (.visitLdcInsn false) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {D0} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {D0, D1} - (.visitInsn Opcodes/DUP2) - (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) - ;; Is greater than... - (.visitLdcInsn false) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $is-less-than) - (.visitInsn Opcodes/POP2) - (.visitLdcInsn true) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $is-equal) - ;; Increment index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $simple-sub (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) - (.visitCode) - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} - (.visitInsn Opcodes/BALOAD) - (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} - (.visitInsn Opcodes/DUP2) - (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Since $0 < $1 - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) ;; $1 - $0 - (.visitLdcInsn (byte 10)) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) - ;; Prepare to iterate... - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Subtract 1 from next digit - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $simple-sub) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} - (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") - (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - $loop-start (new Label) - $do-a-round (new Label) - $skip-power (new Label) - $iterate (new Label) - $bad-format (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - ;; Check prefix - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn ".") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") - (.visitJumpInsn Opcodes/IFEQ $bad-format) - ;; Check if size is valid - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . - (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) - ;; Initialization - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitLabel $from) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") - (.visitLabel $to) - (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn (long 0)) - (.visitVarInsn Opcodes/LSTORE 2) ;; Output - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int deg-bits)) - (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) - (.visitVarInsn Opcodes/LLOAD 2) - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") - (.visitInsn Opcodes/DUP2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") - (.visitJumpInsn Opcodes/IFNE $skip-power) - ;; Subtract power - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") - (.visitVarInsn Opcodes/ASTORE 0) - ;; Set bit on output - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 1)) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int (dec deg-bits))) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LOR) - (.visitVarInsn Opcodes/LSTORE 2) - (.visitJumpInsn Opcodes/GOTO $iterate) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $skip-power) - (.visitInsn Opcodes/POP2) - ;; (.visitJumpInsn Opcodes/GOTO $iterate) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $iterate) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $handler) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $bad-format) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))] - nil)) - -(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] - (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - - $good-start (new Label) - $short-enough (new Label) - $bad-digit (new Label) - $out-of-bounds (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - ;; Remove the + at the beginning... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitLdcInsn "+") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFNE $good-start) - ;; Doesn't start with + - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Starts with + - (.visitLabel $good-start) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... - ;; Begin parsing processs - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 18)) - (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) - ;; Too long - ;; Get prefix... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... - ;; Get last digit... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") - (.visitLdcInsn (int 10)) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") - ;; Test last digit... - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFLT $bad-digit) - ;; Good digit... - ;; Stack: prefix::L, prefix::L, last-digit::I - (.visitInsn Opcodes/I2L) - ;; Build the result... - swap2 - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L - (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L - swap2 ;; Stack: result::L, result::L, prefix::L - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $out-of-bounds) - ;; Within bounds - ;; Stack: result::L - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Out of bounds - (.visitLabel $out-of-bounds) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Bad digit... - (.visitLabel $bad-digit) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; 18 chars or less - (.visitLabel $short-enough) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $to) - (.visitLabel $handler) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 - _ (let [$too-big (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitLdcInsn "+") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $too-big) - ;; then - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - ;; else - (.visitLabel $too-big) - ;; Set up parts of the number string... - ;; First digits - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/LUSHR) - (.visitLdcInsn (long 5)) - (.visitInsn Opcodes/LDIV) ;; quot - ;; Last digit - (.visitInsn Opcodes/DUP2) - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) - swap2 - (.visitInsn Opcodes/LSUB) ;; quot, rem - ;; Conversion to string... - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* - (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* - (.visitInsn Opcodes/POP) ;; rem*, quot - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* - (.visitInsn Opcodes/SWAP) ;; quot*, rem* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 - _ (let [$simple-case (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGE $simple-case) - ;; else - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitLdcInsn (int 32)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - ;; then - (.visitLabel $simple-case) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitInsn Opcodes/LCMP) - (.visitInsn Opcodes/IRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 - _ (let [$case-1 (new Label) - $0 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $case-1) - ;; Test #2 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LDIV) - (.visitInsn Opcodes/LRETURN) - ;; Case #1 - (.visitLabel $case-1) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $0) - ;; 1 - (.visitLdcInsn (long 1)) - (.visitInsn Opcodes/LRETURN) - ;; 0 - (.visitLabel $0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 - _ (let [$test-2 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - ;; Case #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LREM) - (.visitInsn Opcodes/LRETURN) - ;; Test #2 - (.visitLabel $test-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitInsn Opcodes/LRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitMaxs 0 0) - (.visitEnd)))] - nil))) - -(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] - (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn "Invalid expression for pattern-matching.") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(def compile-LuxRT-class - (|do [_ (return nil) - :let [full-name &&/lux-utils-class - super-class (&host-generics/->bytecode-class-name "java.lang.Object") - tag-sig (&host-generics/->type-signature "java.lang.String") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - full-name nil super-class (into-array String []))) - =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) - (.visitEnd)) - =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitLdcInsn "LOG: ") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I - (.visitLdcInsn "") ;; I? - (.visitVarInsn Opcodes/ALOAD 0) ;; I?O - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn "_") - (.visitLdcInsn "") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto =class - (compile-LuxRT-pm-methods) - (compile-LuxRT-adt-methods) - (compile-LuxRT-nat-methods) - (compile-LuxRT-deg-methods))]] - (&&/save-class! (second (string/split &&/lux-utils-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float - ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int - ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long - - ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double - ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int - ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long - - ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte - ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char - ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double - ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float - ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long - ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short - - ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double - ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float - ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int - - ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte - ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short - ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int - ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long - - ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long - - ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long - ) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short - ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - )] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - _ (doto *writer* - (.visitInsn ) - ())]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int - ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int - ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int - ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int - ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float - ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float - - ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int - ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int - ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int - - ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char - ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char - ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn ) - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long - ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long - ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long - - ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float - ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float - ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float - - ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double - ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (doto *writer* - - (.visitInsn ))]] - (return nil))) - ) - - Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean - Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte - Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short - Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int - Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long - Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float - Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double - Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char - ) - -(defn ^:private compile-jvm-anewarray [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] - (return nil))) - -(defn ^:private compile-jvm-aaload [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] - (return nil))) - -(defn ^:private compile-jvm-aastore [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-jvm-arraylength [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-jvm-null [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Nil) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - -(defn ^:private compile-jvm-null? [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IFNULL $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(defn compile-jvm-synchronized [compile ?values special-args] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?monitor) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/MONITORENTER))] - _ (compile ?expr) - :let [_ (doto *writer* - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/MONITOREXIT))]] - (return nil))) - -(defn ^:private compile-jvm-throw [compile ?values special-args] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?ex) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) - -(defn ^:private compile-jvm-getstatic [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-getfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-putstatic [compile ?values special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [=input-sig (&host-type/gclass->sig input-gclass) - _ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-putfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - _ (compile ?value) - =input-sig (&host/->java-sig ?input-type) - :let [_ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-invokestatic [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?object ?args) ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (compile ?object) - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - - ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL - ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL - ) - -(defn ^:private compile-jvm-new [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") - class* (&host-generics/->bytecode-class-name ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [class-name+arg] - (|do [:let [[class-name arg] class-name+arg] - ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (&/zip2 ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] - (return nil))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private compile-jvm-load-class [compile ?values special-args] - (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn _class-name) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-instanceof [compile ?values special-args] - (|do [:let [(&/$Cons object (&/$Nil)) ?values - (&/$Cons class (&/$Nil)) special-args] - :let [class* (&host-generics/->bytecode-class-name class)] - ^MethodVisitor *writer* &/get-writer - _ (compile object) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/INSTANCEOF class*) - (&&/wrap-boolean))]] - (return nil))) - -(defn ^:private compile-array-get [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)] - :let [$is-null (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 1)) - (.visitLdcInsn "") - (.visitInsn Opcodes/DUP2_X1) ;; I?2I? - (.visitInsn Opcodes/POP2) ;; I?2 - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $is-null) - (.visitInsn Opcodes/POP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/ACONST_NULL) - (.visitLdcInsn &/unit-tag) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?mask) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-and Opcodes/LAND - ^:private compile-bit-or Opcodes/LOR - ^:private compile-bit-xor Opcodes/LXOR - ) - -(defn ^:private compile-bit-count [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?shift) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-shift-left Opcodes/LSHL - ^:private compile-bit-shift-right Opcodes/LSHR - ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR - ) - -(defn ^:private compile-lux-== [compile ?values special-args] - (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?left) - _ (compile ?right) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IF_ACMPEQ $then) - ;; else - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - _ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-nat-add Opcodes/LADD - ^:private compile-nat-sub Opcodes/LSUB - ^:private compile-nat-mul Opcodes/LMUL - - ^:private compile-deg-add Opcodes/LADD - ^:private compile-deg-sub Opcodes/LSUB - ^:private compile-deg-rem Opcodes/LSUB - ^:private compile-deg-scale Opcodes/LMUL - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - (&&/wrap-long))]] - (return nil))) - - ^:private compile-nat-div "div_nat" - ^:private compile-nat-rem "rem_nat" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-nat-eq 0 - - ^:private compile-deg-eq 0 - ^:private compile-deg-lt -1 - ) - -(defn ^:private compile-nat-lt [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Nil) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - - )]] - (return nil))) - - ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - - ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] - (return nil))) - - (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] - (return nil))))) - - ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" - ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - &&/wrap-long)]] - (return nil))) - - ^:private compile-deg-mul "mul_deg" - ^:private compile-deg-div "div_deg" - ) - -(do-template [ ] - (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) - )]] - (return nil)))) - - ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double - ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long - ) - -(let [widen (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/I2L))) - shrink (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/I2C)))] - (do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - - )]] - (return nil))) - - ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink - ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen - )) - -(do-template [] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x)] - (return nil))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn compile-host [compile proc-category proc-name ?values special-args] - (case proc-category - "lux" - (case proc-name - "==" (compile-lux-== compile ?values special-args)) - - "bit" - (case proc-name - "count" (compile-bit-count compile ?values special-args) - "and" (compile-bit-and compile ?values special-args) - "or" (compile-bit-or compile ?values special-args) - "xor" (compile-bit-xor compile ?values special-args) - "shift-left" (compile-bit-shift-left compile ?values special-args) - "shift-right" (compile-bit-shift-right compile ?values special-args) - "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - - "array" - (case proc-name - "get" (compile-array-get compile ?values special-args)) - - "nat" - (case proc-name - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - "encode" (compile-nat-encode compile ?values special-args) - "decode" (compile-nat-decode compile ?values special-args) - "max-value" (compile-nat-max-value compile ?values special-args) - "min-value" (compile-nat-min-value compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "deg" - (case proc-name - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - "encode" (compile-deg-encode compile ?values special-args) - "decode" (compile-deg-decode compile ?values special-args) - "max-value" (compile-deg-max-value compile ?values special-args) - "min-value" (compile-deg-min-value compile ?values special-args) - "to-real" (compile-deg-to-real compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - ) - - "int" - (case proc-name - "to-nat" (compile-int-to-nat compile ?values special-args) - ) - - "real" - (case proc-name - "to-deg" (compile-real-to-deg compile ?values special-args) - ) - - "char" - (case proc-name - "to-nat" (compile-char-to-nat compile ?values special-args) - ) - - "jvm" - (case proc-name - "synchronized" (compile-jvm-synchronized compile ?values special-args) - "load-class" (compile-jvm-load-class compile ?values special-args) - "instanceof" (compile-jvm-instanceof compile ?values special-args) - "try" (compile-jvm-try compile ?values special-args) - "new" (compile-jvm-new compile ?values special-args) - "invokestatic" (compile-jvm-invokestatic compile ?values special-args) - "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) - "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) - "invokespecial" (compile-jvm-invokespecial compile ?values special-args) - "getstatic" (compile-jvm-getstatic compile ?values special-args) - "getfield" (compile-jvm-getfield compile ?values special-args) - "putstatic" (compile-jvm-putstatic compile ?values special-args) - "putfield" (compile-jvm-putfield compile ?values special-args) - "throw" (compile-jvm-throw compile ?values special-args) - "null?" (compile-jvm-null? compile ?values special-args) - "null" (compile-jvm-null compile ?values special-args) - "anewarray" (compile-jvm-anewarray compile ?values special-args) - "aaload" (compile-jvm-aaload compile ?values special-args) - "aastore" (compile-jvm-aastore compile ?values special-args) - "arraylength" (compile-jvm-arraylength compile ?values special-args) - "znewarray" (compile-jvm-znewarray compile ?values special-args) - "bnewarray" (compile-jvm-bnewarray compile ?values special-args) - "snewarray" (compile-jvm-snewarray compile ?values special-args) - "inewarray" (compile-jvm-inewarray compile ?values special-args) - "lnewarray" (compile-jvm-lnewarray compile ?values special-args) - "fnewarray" (compile-jvm-fnewarray compile ?values special-args) - "dnewarray" (compile-jvm-dnewarray compile ?values special-args) - "cnewarray" (compile-jvm-cnewarray compile ?values special-args) - "iadd" (compile-jvm-iadd compile ?values special-args) - "isub" (compile-jvm-isub compile ?values special-args) - "imul" (compile-jvm-imul compile ?values special-args) - "idiv" (compile-jvm-idiv compile ?values special-args) - "irem" (compile-jvm-irem compile ?values special-args) - "ieq" (compile-jvm-ieq compile ?values special-args) - "ilt" (compile-jvm-ilt compile ?values special-args) - "igt" (compile-jvm-igt compile ?values special-args) - "ceq" (compile-jvm-ceq compile ?values special-args) - "clt" (compile-jvm-clt compile ?values special-args) - "cgt" (compile-jvm-cgt compile ?values special-args) - "ladd" (compile-jvm-ladd compile ?values special-args) - "lsub" (compile-jvm-lsub compile ?values special-args) - "lmul" (compile-jvm-lmul compile ?values special-args) - "ldiv" (compile-jvm-ldiv compile ?values special-args) - "lrem" (compile-jvm-lrem compile ?values special-args) - "leq" (compile-jvm-leq compile ?values special-args) - "llt" (compile-jvm-llt compile ?values special-args) - "lgt" (compile-jvm-lgt compile ?values special-args) - "fadd" (compile-jvm-fadd compile ?values special-args) - "fsub" (compile-jvm-fsub compile ?values special-args) - "fmul" (compile-jvm-fmul compile ?values special-args) - "fdiv" (compile-jvm-fdiv compile ?values special-args) - "frem" (compile-jvm-frem compile ?values special-args) - "feq" (compile-jvm-feq compile ?values special-args) - "flt" (compile-jvm-flt compile ?values special-args) - "fgt" (compile-jvm-fgt compile ?values special-args) - "dadd" (compile-jvm-dadd compile ?values special-args) - "dsub" (compile-jvm-dsub compile ?values special-args) - "dmul" (compile-jvm-dmul compile ?values special-args) - "ddiv" (compile-jvm-ddiv compile ?values special-args) - "drem" (compile-jvm-drem compile ?values special-args) - "deq" (compile-jvm-deq compile ?values special-args) - "dlt" (compile-jvm-dlt compile ?values special-args) - "dgt" (compile-jvm-dgt compile ?values special-args) - "iand" (compile-jvm-iand compile ?values special-args) - "ior" (compile-jvm-ior compile ?values special-args) - "ixor" (compile-jvm-ixor compile ?values special-args) - "ishl" (compile-jvm-ishl compile ?values special-args) - "ishr" (compile-jvm-ishr compile ?values special-args) - "iushr" (compile-jvm-iushr compile ?values special-args) - "land" (compile-jvm-land compile ?values special-args) - "lor" (compile-jvm-lor compile ?values special-args) - "lxor" (compile-jvm-lxor compile ?values special-args) - "lshl" (compile-jvm-lshl compile ?values special-args) - "lshr" (compile-jvm-lshr compile ?values special-args) - "lushr" (compile-jvm-lushr compile ?values special-args) - "d2f" (compile-jvm-d2f compile ?values special-args) - "d2i" (compile-jvm-d2i compile ?values special-args) - "d2l" (compile-jvm-d2l compile ?values special-args) - "f2d" (compile-jvm-f2d compile ?values special-args) - "f2i" (compile-jvm-f2i compile ?values special-args) - "f2l" (compile-jvm-f2l compile ?values special-args) - "i2b" (compile-jvm-i2b compile ?values special-args) - "i2c" (compile-jvm-i2c compile ?values special-args) - "i2d" (compile-jvm-i2d compile ?values special-args) - "i2f" (compile-jvm-i2f compile ?values special-args) - "i2l" (compile-jvm-i2l compile ?values special-args) - "i2s" (compile-jvm-i2s compile ?values special-args) - "l2d" (compile-jvm-l2d compile ?values special-args) - "l2f" (compile-jvm-l2f compile ?values special-args) - "l2i" (compile-jvm-l2i compile ?values special-args) - "l2s" (compile-jvm-l2s compile ?values special-args) - "l2b" (compile-jvm-l2b compile ?values special-args) - "c2b" (compile-jvm-c2b compile ?values special-args) - "c2s" (compile-jvm-c2s compile ?values special-args) - "c2i" (compile-jvm-c2i compile ?values special-args) - "c2l" (compile-jvm-c2l compile ?values special-args) - "s2l" (compile-jvm-s2l compile ?values special-args) - "b2l" (compile-jvm-b2l compile ?values special-args) - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj index 3ee19988f..82b80f624 100644 --- a/luxc/src/lux/compiler/io.clj +++ b/luxc/src/lux/compiler/io.clj @@ -1,6 +1,6 @@ (ns lux.compiler.io (:require (lux [base :as & :refer [|case |let |do return* return fail*]]) - (lux.compiler [base :as &&]) + (lux.compiler.jvm [base :as &&]) [lux.lib.loader :as &lib])) ;; [Utils] diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj new file mode 100644 index 000000000..5d787f5cd --- /dev/null +++ b/luxc/src/lux/compiler/jvm.clj @@ -0,0 +1,228 @@ +(ns lux.compiler.jvm + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]] + [type :as &type] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &optimizer] + [host :as &host]) + [lux.host.generics :as &host-generics] + [lux.optimizer :as &o] + [lux.analyser.base :as &a] + [lux.analyser.module :as &a-module] + (lux.compiler [core :as &&core] + [io :as &&io] + [parallel :as &¶llel]) + (lux.compiler.jvm [base :as &&] + [cache :as &&cache] + [lux :as &&lux] + [host :as &&host] + [case :as &&case] + [lambda :as &&lambda])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Resources] +(def ^:private !source->last-line (atom nil)) + +(defn ^:private compile-expression [$begin syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&o/$bool ?value) + (&&lux/compile-bool ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$deg ?value) + (&&lux/compile-deg ?value) + + (&o/$real ?value) + (&&lux/compile-real ?value) + + (&o/$char ?value) + (&&lux/compile-char ?value) + + (&o/$text ?value) + (&&lux/compile-text ?value) + + (&o/$tuple ?elems) + (&&lux/compile-tuple (partial compile-expression $begin) ?elems) + + (&o/$var (&/$Local ?idx)) + (&&lux/compile-local (partial compile-expression $begin) ?idx) + + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) + + (&o/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) + + (&o/$apply ?fn ?args) + (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) + + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) + + (&o/$iter _register-offset ?args) + (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) + + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) + + (&o/$case ?value [?pm ?bodies]) + (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) + + (&o/$let _value _register _body) + (&&lux/compile-let (partial compile-expression $begin) _value _register _body) + + (&o/$record-get _value _path) + (&&lux/compile-record-get (partial compile-expression $begin) _value _path) + + (&o/$if _test _then _else) + (&&lux/compile-if (partial compile-expression $begin) _test _then _else) + + (&o/$function _register-offset ?arity ?scope ?env ?body) + (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body) + + (&o/$ann ?value-ex ?type-ex) + (compile-expression $begin ?value-ex) + + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) + + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) + )) + +(defn init! + "(-> (List Text) Null)" + [resources-dirs ^String target-dir] + (do (reset! !source->last-line {}) + (let [class-loader (ClassLoader/getSystemClassLoader) + addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL])) + (.setAccessible true))] + (doseq [^String resources-dir (&/->seq resources-dirs)] + (.invoke addURL class-loader + (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)])))))) + +(defn eval! [expr] + (&/with-eval + (|do [module &/get-module-name + id &/gen-id + [file-name _ _] &/cursor + :let [class-name (str (&host/->module-class module) "/" id) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + class-name nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitCode *writer*)] + _ (compile-expression nil expr) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [bytecode (.toByteArray (doto =class + .visitEnd))] + _ (&&/save-class! (str id) bytecode) + loader &/loader] + (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) + (.getField &/eval-field) + (.get nil) + return)))) + +(def all-compilers + (let [compile-expression* (partial compile-expression nil)] + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression*) + (partial &&host/compile-jvm-class compile-expression*) + &&host/compile-jvm-interface]))) + +(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + +datum-sig+ "Ljava/lang/Object;"] + (defn compile-module [source-dirs name] + (let [file-name (str name ".lux")] + (|do [file-content (&&io/read-file source-dirs file-name) + :let [file-hash (hash file-content) + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] + (&/|eitherL (&&cache/load name) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc "[Compiler Error] Can't re-define a module!") + (|do [_ (&&cache/delete name) + _ (&a-module/create-module name file-hash) + _ (&/flag-active-module name) + :let [module-class-name (str (&host/->module-class name) "/_") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + module-class-name nil "java/lang/Object" nil) + (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) + .visitEnd) + (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) + .visitEnd) + (.visitSource file-name nil))] + _ (if (= "lux" name) + (|do [_ &&host/compile-Function-class + _ &&host/compile-LuxRT-class] + (return nil)) + (return nil))] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [:let [_ (.visitEnd =class)] + _ (&/flag-compiled-module name) + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + module-descriptor &&core/generate-module-descriptor + _ (&&core/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message)))))))) + ) + ))) + +(let [!err! *err*] + (defn compile-program [mode program-module resources-dir source-dirs target-dir] + (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs) + _ (compile-module source-dirs "lux")] + (compile-module source-dirs program-module))] + (|case (m-action (&/init-state mode)) + (&/$Right ?state _) + (do (println "Compilation complete!") + (&&cache/clean ?state)) + + (&/$Left ?message) + (binding [*out* !err!] + (do (println (str "Compilation failed:\n" ?message)) + (flush) + (System/exit 1))))))) diff --git a/luxc/src/lux/compiler/jvm/base.clj b/luxc/src/lux/compiler/jvm/base.clj new file mode 100644 index 000000000..268b293e9 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/base.clj @@ -0,0 +1,87 @@ +(ns lux.compiler.jvm.base + (:require (clojure [template :refer [do-template]] + [string :as string]) + [clojure.java.io :as io] + [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail*]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module]) + [lux.host.generics :as &host-generics] + [lux.compiler.core :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Constants] +(def ^:const ^String function-class "lux/Function") +(def ^:const ^String lux-utils-class "lux/LuxRT") +(def ^:const ^String unit-tag-field "unit_tag") + +;; Formats +(def ^:const ^String local-prefix "l") +(def ^:const ^String partial-prefix "p") +(def ^:const ^String closure-prefix "c") +(def ^:const ^String apply-method "apply") +(defn ^String apply-signature [n] + (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) +(def ^:const num-apply-variants 8) +(def ^:const arity-field "_arity_") +(def ^:const partials-field "_partials_") + +;; [Utils] +(defn ^:private write-output [module name data] + (let [^String module* (&host/->module-class module) + module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] + (.mkdirs (File. module-dir)) + (&&/write-file (str module-dir java.io.File/separator name ".class") data))) + +(defn class-exists? [^String module ^String class-name] + "(-> Text Text (IO Bool))" + (|do [_ (return nil) + :let [full-path (str @&&/!output-dir java.io.File/separator module java.io.File/separator class-name ".class") + exists? (.exists (File. full-path))]] + (return exists?))) + +;; [Exports] +(defn ^Class load-class! [^ClassLoader loader name] + ;; (prn 'load-class! name) + (.loadClass loader name)) + +(defn save-class! [name bytecode] + (|do [eval? &/get-eval + module &/get-module-name + loader &/loader + !classes &/classes + :let [real-name (str (&host-generics/->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (when (not eval?) + (write-output module name bytecode)) + _ (load-class! loader real-name)]] + (return nil))) + +(do-template [ ] + (do (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))) + (defn [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) + + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 + ) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj new file mode 100644 index 000000000..1746514bc --- /dev/null +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -0,0 +1,275 @@ +(ns lux.compiler.jvm.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [core :as &&core] + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann]) + (lux.compiler.jvm [base :as &&])) + (:import (java.io File + BufferedOutputStream + FileOutputStream) + (java.lang.reflect Field))) + +;; [Utils] +(defn ^:private read-file [^File file] + "(-> File (Array Byte))" + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +(defn ^:private clean-file [^File file] + "(-> File (,))" + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" + (-> class ^Field (.getField field-name) (.get nil))) + +;; [Resources] +(def module-class-file (str &/module-class-name ".class")) + +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator) + java.io.File/separator + module-class-file)))) + +(defn delete [module] + "(-> Text (Lux Null))" + (fn [state] + (do (clean-file (new File (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator)))) + (return* state nil)))) + +(defn ^:private module-dirs + "(-> File (clojure.Seq File))" + [^File module] + (->> module + .listFiles + (filter #(.isDirectory ^File %)) + (map module-dirs) + (apply concat) + (list* module))) + +(defn clean [state] + "(-> Compiler Null)" + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) + outdated? #(->> % (contains? needed-modules) not) + outdated-modules (->> (new File ^String @&&core/!output-dir) + .listFiles (filter #(.isDirectory ^File %)) + (map module-dirs) doall (apply concat) + (map (fn [^File dir-file] + (let [^String dir-module (-> dir-file + .getAbsolutePath + (string/replace output-dir-prefix "")) + corrected-dir-module (.replace dir-module java.io.File/separator "/")] + corrected-dir-module))) + (filter outdated?))] + (doseq [^String f outdated-modules] + (clean-file (new File (str output-dir-prefix f)))) + nil)) + +(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] + (let [classes+bytecode (for [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= module-class-file file-name)] + [(second (re-find #"^(.*)\.class$" file-name)) + (read-file file)]) + _ (doseq [[class-name bytecode] classes+bytecode] + (swap! !classes assoc (str module* "." class-name) bytecode))] + (map first classes+bytecode))) + +(defn ^:private assume-async-result + "(-> (Error Compiler) (Lux Null))" + [result] + (fn [_] + (|case result + (&/$Left error) + (&/$Left error) + + (&/$Right compiler) + (return* compiler nil)))) + +(defn ^:private parse-tag-groups [^String tags-section] + (if (= "" tags-section) + &/$Nil + (-> tags-section + (.split &&core/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&core/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))) + +(defn ^:private process-tag-group [module group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + +(defn ^:private process-def-entry [loader module ^String _def-entry] + (let [parts (.split _def-entry &&core/datum-separator)] + (case (alength parts) + 2 (let [[_name _alias] parts + [_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) + def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))])) + def-value (get-field &/value-field def-class)] + (|do [def-type (&a-module/def-type __module __name)] + (&a-module/define module _name def-type def-anns def-value))) + 3 (let [[_name _type _anns] parts + def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name _name))) + def-anns (&&&ann/deserialize-anns _anns) + [def-type _] (&&&type/deserialize-type _type) + def-value (get-field &/value-field def-class)] + (&a-module/define module _name def-type def-anns def-value))))) + +(defn ^:private uninstall-cache [module] + (|do [_ (delete module)] + (return false))) + +(defn ^:private install-module [loader module module-hash imports tag-groups module-anns def-entries] + (|do [_ (&a-module/create-module module module-hash) + _ (&a-module/set-anns module-anns module) + _ (&a-module/set-imports imports) + _ (&/map% (partial process-def-entry loader module) + def-entries) + _ (&/map% (partial process-tag-group module) tag-groups)] + (return nil))) + +(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader] + (|do [^String descriptor (&&core/read-module-descriptor! module-name) + :let [[imports-section tags-section module-anns-section defs-section] (.split descriptor &&core/section-separator) + imports (let [imports (vec (.split ^String imports-section &&core/entry-separator)) + imports (if (= [""] imports) + &/$Nil + (&/->list imports))] + (&/|map #(.split ^String % &&core/datum-separator 2) imports))] + cache-table* (&/fold% (fn [cache-table* _import] + (|do [:let [[_module _hash] _import] + file-content (&&io/read-file source-dirs (str _module ".lux")) + output (pre-load! source-dirs cache-table* _module (hash file-content))] + (return output))) + cache-table + imports)] + (if (&/|every? (fn [_import] + (|let [[_module _hash] _import] + (contains? cache-table* _module))) + imports) + (let [tag-groups (parse-tag-groups tags-section) + module-anns (&&&ann/deserialize-anns module-anns-section) + def-entries (let [def-entries (vec (.split ^String defs-section &&core/entry-separator))] + (if (= [""] def-entries) + &/$Nil + (&/->list def-entries)))] + (|do [_ (install-module loader module-name module-hash + imports tag-groups module-anns def-entries) + =module (&/find-module module-name)] + (return (&/T [true (assoc cache-table* module-name =module)])))) + (return (&/T [false cache-table*]))))) + +(defn ^:private enumerate-cached-modules!* [^File parent] + (if (.isDirectory parent) + (let [children (for [^File child (seq (.listFiles parent)) + entry (enumerate-cached-modules!* child)] + entry)] + (if (.exists (new File parent "_.class")) + (list* (.getAbsolutePath parent) + children) + children)) + (list))) + +(defn ^:private enumerate-cached-modules! [] + (let [output-dir (new File ^String @&&core/!output-dir) + prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] + (->> output-dir + enumerate-cached-modules!* + rest + (map #(-> ^String % + (.replace java.io.File/separator "/") + (.substring prefix-to-subtract))) + &/->list))) + +(defn ^:private pre-load! [source-dirs cache-table module module-hash] + (cond (contains? cache-table module) + (return cache-table) + + (not (cached? module)) + (return cache-table) + + :else + (|do [loader &/loader + !classes &/classes + :let [module* (&host-generics/->class-name module) + module-path (str @&&core/!output-dir java.io.File/separator module) + class-name (str module* "." &/module-class-name) + ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) + (&&/load-class! loader class-name)) + installed-classes (install-all-classes-in-module !classes module* module-path) + valid-cache? (and (= module-hash (get-field &/hash-field module-class)) + (= &/compiler-version (get-field &/compiler-field module-class))) + drop-cache! (|do [_ (uninstall-cache module) + :let [_ (swap! !classes (fn [_classes-dict] + (reduce dissoc _classes-dict installed-classes)))]] + (return cache-table))]] + (if valid-cache? + (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module module-hash loader) + _ (if success? + (return nil) + drop-cache!)] + (return cache-table*)) + drop-cache!)))) + +(def !pre-loaded-cache (atom nil)) +(defn pre-load-cache! [source-dirs] + (|do [:let [fs-cached-modules (enumerate-cached-modules!)] + pre-loaded-modules (&/fold% (fn [cache-table module-name] + (fn [_compiler] + (|case ((&&io/read-file source-dirs (str module-name ".lux")) + _compiler) + (&/$Left error) + (return* _compiler cache-table) + + (&/$Right _compiler* file-content) + ((pre-load! source-dirs cache-table module-name (hash file-content)) + _compiler*)))) + {} + fs-cached-modules) + :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] + (return nil))) + +(defn ^:private inject-module + "(-> (Module Compiler) (-> Compiler (Lux Null)))" + [module-name module] + (fn [compiler] + (return* (&/update$ &/$modules + #(&/|put module-name module %) + compiler) + nil))) + +(defn load [module-name] + "(-> Text (Lux Null))" + (if-let [module-struct (get @!pre-loaded-cache module-name)] + (|do [_ (inject-module module-name module-struct) + _ (&/flag-cached-module module-name)] + (return nil)) + (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/compiler/jvm/case.clj b/luxc/src/lux/compiler/jvm/case.clj new file mode 100644 index 000000000..da8d8d0a9 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/case.clj @@ -0,0 +1,214 @@ +(ns lux.compiler.jvm.case + (:require (clojure [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.analyser.case :as &a-case] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] + (cond (= 0 stack-depth) + writer + + (= 1 stack-depth) + (doto writer + (.visitInsn Opcodes/POP)) + + (= 2 stack-depth) + (doto writer + (.visitInsn Opcodes/POP2)) + + :else ;; > 2 + (doto writer + (.visitInsn Opcodes/POP2) + (pop-alt-stack (- stack-depth 2))))) + +(defn ^:private stack-peek [^MethodVisitor writer] + (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;"))) + +(defn ^:private compile-pattern* [^MethodVisitor writer bodies stack-depth $else pm] + "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" + (|case pm + (&o/$ExecPM _body-idx) + (|case (&/|at _body-idx bodies) + (&/$Some $body) + (doto writer + (pop-alt-stack stack-depth) + (.visitJumpInsn Opcodes/GOTO $body)) + + (&/$None) + (assert false)) + + (&o/$PopPM) + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BindPM _var-id) + (doto writer + stack-peek + (.visitVarInsn Opcodes/ASTORE _var-id) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;")) + + (&o/$BoolPM _value) + (doto writer + stack-peek + &&/unwrap-boolean + (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) + + (&o/$NatPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$IntPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$DegPM _value) + (doto writer + stack-peek + &&/unwrap-long + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$RealPM _value) + (doto writer + stack-peek + &&/unwrap-double + (.visitLdcInsn (double _value)) + (.visitInsn Opcodes/DCMPL) + (.visitJumpInsn Opcodes/IFNE $else)) + + (&o/$CharPM _value) + (doto writer + stack-peek + &&/unwrap-char + (.visitLdcInsn _value) + (.visitJumpInsn Opcodes/IF_ICMPNE $else)) + + (&o/$TextPM _value) + (doto writer + stack-peek + (.visitLdcInsn _value) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else)) + + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true]))] + (if (= 0 _idx) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" (if is-tail? "product_getRight" "product_getLeft") "([Ljava/lang/Object;I)Ljava/lang/Object;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + ))) + + (&o/$VariantPM _idx+) + (|let [$success (new Label) + $fail (new Label) + [_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + _ (doto writer + stack-peek + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int _idx))) + _ (if is-last + (.visitLdcInsn writer "") + (.visitInsn writer Opcodes/ACONST_NULL))] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $fail) + (.visitJumpInsn Opcodes/GOTO $success) + (.visitLabel $fail) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $success) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) + + (&o/$SeqPM _left-pm _right-pm) + (doto writer + (compile-pattern* bodies stack-depth $else _left-pm) + (compile-pattern* bodies stack-depth $else _right-pm)) + + (&o/$AltPM _left-pm _right-pm) + (|let [$alt-else (new Label)] + (doto writer + (.visitInsn Opcodes/DUP) + (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) + (.visitLabel $alt-else) + (.visitInsn Opcodes/POP) + (compile-pattern* bodies stack-depth $else _right-pm))) + )) + +(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] + (|let [$else (new Label)] + (doto writer + (compile-pattern* bodies 1 $else pm) + (.visitLabel $else) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_fail" "()V") + (.visitInsn Opcodes/ACONST_NULL) + (.visitJumpInsn Opcodes/GOTO $end)))) + +(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] + (&/map% (fn [label+body] + (|let [[_label _body] label+body] + (|do [:let [_ (.visitLabel writer _label)] + _ (compile _body) + :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] + (return nil)))) + (&/zip2 bodies-labels ?bodies))) + +;; [Resources] +(defn compile-case [compile ?value ?pm ?bodies] + (|do [^MethodVisitor *writer* &/get-writer + :let [$end (new Label) + bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] + _ (compile ?value) + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) + _ (compile-pattern *writer* bodies-labels ?pm $end)] + _ (compile-bodies *writer* compile bodies-labels ?bodies $end) + :let [_ (.visitLabel *writer* $end)]] + (return nil))) diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj new file mode 100644 index 000000000..34a5a2bb7 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/host.clj @@ -0,0 +1,2762 @@ +(ns lux.compiler.jvm.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "") + +(let [class+method+sig {"boolean" &&/unwrap-boolean + "byte" &&/unwrap-byte + "short" &&/unwrap-short + "int" &&/unwrap-int + "long" &&/unwrap-long + "float" &&/unwrap-float + "double" &&/unwrap-double + "char" &&/unwrap-char}] + (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] + (if-let [unwrap (get class+method+sig class-name)] + (doto *writer* + unwrap) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) + +(let [boolean-class "java.lang.Boolean" + byte-class "java.lang.Byte" + short-class "java.lang.Short" + int-class "java.lang.Integer" + long-class "java.lang.Long" + float-class "java.lang.Float" + double-class "java.lang.Double" + char-class "java.lang.Character"] + (defn prepare-return! [^MethodVisitor *writer* *type*] + (|case *type* + (&/$UnitT) + (.visitLdcInsn *writer* &/unit-tag) + + (&/$HostT "boolean" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) + + (&/$HostT "byte" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) + + (&/$HostT "short" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) + + (&/$HostT "int" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) + + (&/$HostT "long" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) + + (&/$HostT "float" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) + + (&/$HostT "double" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) + + (&/$HostT "char" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) + + (&/$HostT _ _) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + (&/$ExT _) + nil + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) + *writer*)) + +;; [Resources] +(defn ^:private compile-annotation [writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|let [=field (.visitField writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) + ?name + (&host-generics/gclass->simple-signature ?gclass) + (&host-generics/gclass->signature ?gclass) nil)] + (do (&/|map (partial compile-annotation =field) ?anns) + (.visitEnd =field) + nil)) + + (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) + (|let [=field (.visitField writer + (+ (&host/privacy-modifier->flag =privacy-modifier) + (&host/state-modifier->flag =state-modifier)) + =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil)) + )) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass _class-name (&/$Nil)) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) + (.visitInsn Opcodes/ARETURN)) + + _ + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) + ;; else + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) + + [_ gclass] + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) + )) + +(defn ^:private prepare-method-inputs [idx inputs method-visitor] + "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + (|case inputs + (&/$Nil) + (return &/$Nil) + + (&/$Cons input inputs*) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) + )) + +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/$GenericClass "void" (&/|list)) + =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0)) + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] + _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) + :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if =final? Opcodes/ACC_FINAL 0) + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0) + Opcodes/ACC_STATIC) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_ABSTRACT + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + + (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + )) + +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + _ (&/|map (partial compile-annotation =method) =anns) + _ (.visitEnd =method)] + nil)) + +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + &&/unwrap-boolean) + "byte" (doto writer + &&/unwrap-byte) + "short" (doto writer + &&/unwrap-short) + "int" (doto writer + &&/unwrap-int) + "long" (doto writer + &&/unwrap-long) + "float" (doto writer + &&/unwrap-float) + "double" (doto writer + &&/unwrap-double) + "char" (doto writer + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) + +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") + -return "V"] + (defn ^:private anon-class--signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + -return)) + + (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] + (|let [[super-class-name super-class-params] super-class + init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ) + +(defn ^:private constant-inits [fields] + "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + (&/fold &/|++ + &/$Nil + (&/|map (fn [field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (&/|list (&/T [?name ?gclass ?value])) + + (&/$VariableFieldSyntax _) + (&/|list) + )) + fields))) + +(declare compile-jvm-putstatic) +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] + (|do [module &/get-module-name + [file-name line column] &/cursor + :let [[?name ?params] class-decl + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) + full-name (str module "/" ?name) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + (&host/inheritance-modifier->flag ?inheritance-modifier)) + full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class- =class compile full-name ?super-class env ctor-args) + + _ + (return nil)) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode))] + _ (&/map% (fn [ftriple] + (|let [[fname fgclass fvalue] ftriple] + (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) + (constant-inits ?fields)) + :let [_ (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] + (|do [:let [[interface-name interface-vars] interface-decl] + module &/get-module-name + [file-name _ _] &/cursor + :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) + (str module "/" interface-name) + (if (= "" interface-signature) nil interface-signature) + "java/lang/Object" + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) + (.visitEnd =interface))]] + (&&/save-class! interface-name (.toByteArray =interface)))) + +(def compile-Function-class + (|do [_ (return nil) + :let [super-class "java/lang/Object" + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + Opcodes/ACC_ABSTRACT + ;; Opcodes/ACC_INTERFACE + ) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) + (.visitCode) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitVarInsn Opcodes/ALOAD arity) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))))]] + (&&/save-class! (second (string/split &&/function-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] + (|let [_ (let [$begin (new Label) + $not-rec (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size + (.visitInsn Opcodes/ISUB) ;; sub-index + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple + (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size + (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem + (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $is-last) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $just-return (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; I commented-out some parts because a null-check was + ;; done to ensure variants were never created with null + ;; values (this would interfere later with + ;; pattern-matching). + ;; Since Lux itself doesn't have null values as part of + ;; the language, the burden of ensuring non-nulls was + ;; shifted to library code dealing with host-interop, to + ;; ensure variant-making was as fast as possible. + ;; The null-checking code was left as comments in case I + ;; ever change my mind. + _ (let [;; $is-null (new Label) + ] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + ;; (.visitLabel $is-null) + ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + ;; (.visitInsn Opcodes/DUP) + ;; (.visitLdcInsn "Can't create variant for null pointer") + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + ;; (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(defn ^:private low-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. + (.visitLdcInsn (int -1)) + (.visitInsn Opcodes/I2L) + ;; Then do a bitwise and. + (.visitInsn Opcodes/LAND) + )) + +(defn ^:private high-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + )) + +(defn ^:private swap2 [^MethodVisitor =method] + (doto =method + ;; X2, Y2 + (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X2 + )) + +(defn ^:private swap2x1 [^MethodVisitor =method] + (doto =method + ;; X1, Y2 + (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X1 + )) + +(defn ^:private bit-set-64? [^MethodVisitor =method] + (doto =method + ;; L, I + (.visitLdcInsn (long 1)) ;; L, I, L + (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L + (.visitInsn Opcodes/POP2) ;; L, L, I + (.visitInsn Opcodes/LSHL) ;; L, L + (.visitInsn Opcodes/LAND) ;; L + (.visitLdcInsn (long 0)) ;; L, L + (.visitInsn Opcodes/LCMP) ;; I + )) + +(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] + (|let [deg-bits 64 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) + ;; Based on: http://stackoverflow.com/a/31629280/6823464 + (.visitCode) + ;; Bottom part + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Middle part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) + ;; Join middle and bottom + (.visitInsn Opcodes/LADD) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Top part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + ;; Join top with rest + (.visitInsn Opcodes/LADD) + ;; Return + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) + (.visitCode) + ;; Based on: http://stackoverflow.com/a/8510587/6823464 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LDIV) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) + (.visitCode) + ;; Translate high bytes + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Translate low bytes + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Combine and return + (.visitInsn Opcodes/DADD) + (.visitInsn Opcodes/DRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) + (.visitCode) + ;; Drop any excess + (.visitVarInsn Opcodes/DLOAD 0) + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + ;; Shift upper half, but retain remaining decimals + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Make a copy, so the lower half can be extracted + (.visitInsn Opcodes/DUP2) + ;; Get that lower half + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Turn it into a deg + (.visitInsn Opcodes/D2L) + ;; Turn the upper half into deg too + swap2 + (.visitInsn Opcodes/D2L) + ;; Combine both pieces + (.visitInsn Opcodes/LADD) + ;; FINISH + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int 0)) ;; {carry} + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} + (.visitLdcInsn (int 5)) + (.visitInsn Opcodes/IMUL) + (.visitInsn Opcodes/IADD) ;; {next-raw-digit} + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 0) + swap2x1 + (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IDIV) ;; {next-carry} + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 0) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) + (.visitCode) + ;; Initialize digits array. + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 + (.visitVarInsn Opcodes/ASTORE 1) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitVarInsn Opcodes/ILOAD 0) ;; {times} + (.visitLabel $loop-start) + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + ;; {times} + (.visitVarInsn Opcodes/ILOAD 0) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} + (.visitVarInsn Opcodes/ASTORE 1) ;; {times} + ;; Decrement index + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + ;; {times-1} + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits + (.visitLdcInsn (int 0)) ;; {carry} + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + ;; {carry} + (.visitVarInsn Opcodes/ALOAD 3) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {carry, dL} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} + (.visitInsn Opcodes/IADD) + (.visitInsn Opcodes/IADD) ;; {raw-next-digit} + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} + (.visitVarInsn Opcodes/ALOAD 3) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IDIV) ;; {next-carry} + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn "") ;; {text} + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitInsn Opcodes/BALOAD) ;; {text, digit} + (.visitLdcInsn (int 10)) ;; {text, digit, radix} + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $not-set (new Label) + $next-iteration (new Label) + $normal-path (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + ;; A quick corner-case to handle. + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $normal-path) + (.visitLdcInsn ".0") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $normal-path) + ;; Normal case + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 3) ;; digits + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + ;; Prepare text to return. + (.visitVarInsn Opcodes/ALOAD 3) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") + (.visitLdcInsn ".") + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; Trim unnecessary 0s at the end... + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + bit-set-64? + (.visitJumpInsn Opcodes/IFEQ $next-iteration) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") + (.visitVarInsn Opcodes/ALOAD 3) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") + (.visitVarInsn Opcodes/ASTORE 3) + (.visitJumpInsn Opcodes/GOTO $next-iteration) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $next-iteration) + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $not-set (new Label) + $next-iteration (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 2) ;; digits + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") + ;; Set digit + (.visitVarInsn Opcodes/ALOAD 2) + (.visitVarInsn Opcodes/ILOAD 1) + swap2x1 + (.visitInsn Opcodes/BASTORE) + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $is-less-than (new Label) + $is-equal (new Label)] + ;; [B0 <= [B1 + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) + (.visitCode) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int deg-bits)) + (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {D0} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {D0, D1} + (.visitInsn Opcodes/DUP2) + (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) + ;; Is greater than... + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $is-less-than) + (.visitInsn Opcodes/POP2) + (.visitLdcInsn true) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $is-equal) + ;; Increment index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $simple-sub (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) + (.visitCode) + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} + (.visitInsn Opcodes/BALOAD) + (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} + (.visitInsn Opcodes/DUP2) + (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Since $0 < $1 + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) ;; $1 - $0 + (.visitLdcInsn (byte 10)) + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) + ;; Prepare to iterate... + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Subtract 1 from next digit + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $simple-sub) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} + (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") + (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + $loop-start (new Label) + $do-a-round (new Label) + $skip-power (new Label) + $iterate (new Label) + $bad-format (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + ;; Check prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ".") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $bad-format) + ;; Check if size is valid + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . + (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) + ;; Initialization + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") + (.visitLabel $to) + (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn (long 0)) + (.visitVarInsn Opcodes/LSTORE 2) ;; Output + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int deg-bits)) + (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) + (.visitVarInsn Opcodes/LLOAD 2) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") + (.visitInsn Opcodes/DUP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") + (.visitJumpInsn Opcodes/IFNE $skip-power) + ;; Subtract power + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") + (.visitVarInsn Opcodes/ASTORE 0) + ;; Set bit on output + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 1)) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int (dec deg-bits))) + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LOR) + (.visitVarInsn Opcodes/LSTORE 2) + (.visitJumpInsn Opcodes/GOTO $iterate) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $skip-power) + (.visitInsn Opcodes/POP2) + ;; (.visitJumpInsn Opcodes/GOTO $iterate) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $iterate) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $bad-format) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] + (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + + $good-start (new Label) + $short-enough (new Label) + $bad-digit (new Label) + $out-of-bounds (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + ;; Remove the + at the beginning... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitLdcInsn "+") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFNE $good-start) + ;; Doesn't start with + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Starts with + + (.visitLabel $good-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... + ;; Begin parsing processs + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 18)) + (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) + ;; Too long + ;; Get prefix... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... + ;; Get last digit... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitLdcInsn (int 10)) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") + ;; Test last digit... + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFLT $bad-digit) + ;; Good digit... + ;; Stack: prefix::L, prefix::L, last-digit::I + (.visitInsn Opcodes/I2L) + ;; Build the result... + swap2 + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L + (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L + swap2 ;; Stack: result::L, result::L, prefix::L + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $out-of-bounds) + ;; Within bounds + ;; Stack: result::L + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Out of bounds + (.visitLabel $out-of-bounds) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Bad digit... + (.visitLabel $bad-digit) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; 18 chars or less + (.visitLabel $short-enough) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 + _ (let [$too-big (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn "+") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $too-big) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + ;; else + (.visitLabel $too-big) + ;; Set up parts of the number string... + ;; First digits + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/LUSHR) + (.visitLdcInsn (long 5)) + (.visitInsn Opcodes/LDIV) ;; quot + ;; Last digit + (.visitInsn Opcodes/DUP2) + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) + swap2 + (.visitInsn Opcodes/LSUB) ;; quot, rem + ;; Conversion to string... + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* + (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* + (.visitInsn Opcodes/POP) ;; rem*, quot + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* + (.visitInsn Opcodes/SWAP) ;; quot*, rem* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + _ (let [$simple-case (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGE $simple-case) + ;; else + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitLdcInsn (int 32)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + ;; then + (.visitLabel $simple-case) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + _ (let [$case-1 (new Label) + $0 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LDIV) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $0) + ;; 1 + (.visitLdcInsn (long 1)) + (.visitInsn Opcodes/LRETURN) + ;; 0 + (.visitLabel $0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + _ (let [$test-2 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + ;; Case #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LREM) + (.visitInsn Opcodes/LRETURN) + ;; Test #2 + (.visitLabel $test-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitInsn Opcodes/LRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd)))] + nil))) + +(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(def compile-LuxRT-class + (|do [_ (return nil) + :let [full-name &&/lux-utils-class + super-class (&host-generics/->bytecode-class-name "java.lang.Object") + tag-sig (&host-generics/->type-signature "java.lang.String") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) + =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I + (.visitLdcInsn "") ;; I? + (.visitVarInsn Opcodes/ALOAD 0) ;; I?O + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto =class + (compile-LuxRT-pm-methods) + (compile-LuxRT-adt-methods) + (compile-LuxRT-nat-methods) + (compile-LuxRT-deg-methods))]] + (&&/save-class! (second (string/split &&/lux-utils-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(do-template [ ] + (defn [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float + ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int + ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long + + ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double + ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int + ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long + + ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte + ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char + ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double + ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float + ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long + ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short + + ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double + ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float + ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int + + ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte + ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short + ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int + ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long + + ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long + + ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long + ) + +(do-template [ ] + (defn [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short + ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + )] + :let [_ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + _ (doto *writer* + (.visitInsn ) + ())]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int + ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int + ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int + ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int + ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float + ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float + + ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int + ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int + ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int + + ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char + ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn ) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long + ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long + + ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float + ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float + ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float + + ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double + ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + + (.visitInsn ))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn ^:private compile-jvm-anewarray [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] + (return nil))) + +(defn ^:private compile-jvm-aaload [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] + (return nil))) + +(defn ^:private compile-jvm-aastore [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-jvm-arraylength [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-jvm-null [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Nil) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + +(defn ^:private compile-jvm-null? [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IFNULL $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-jvm-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + +(defn ^:private compile-jvm-throw [compile ?values special-args] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?ex) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) + +(defn ^:private compile-jvm-getstatic [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-getfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-putstatic [compile ?values special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [=input-sig (&host-type/gclass->sig input-gclass) + _ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-putfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) + =input-sig (&host/->java-sig ?input-type) + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-invokestatic [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?object ?args) ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (compile ?object) + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(defn ^:private compile-jvm-new [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private compile-jvm-load-class [compile ?values special-args] + (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn _class-name) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-instanceof [compile ?values special-args] + (|do [:let [(&/$Cons object (&/$Nil)) ?values + (&/$Cons class (&/$Nil)) special-args] + :let [class* (&host-generics/->bytecode-class-name class)] + ^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)] + :let [$is-null (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 1)) + (.visitLdcInsn "") + (.visitInsn Opcodes/DUP2_X1) ;; I?2I? + (.visitInsn Opcodes/POP2) ;; I?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $is-null) + (.visitInsn Opcodes/POP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/ACONST_NULL) + (.visitLdcInsn &/unit-tag) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?mask) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-and Opcodes/LAND + ^:private compile-bit-or Opcodes/LOR + ^:private compile-bit-xor Opcodes/LXOR + ) + +(defn ^:private compile-bit-count [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?shift) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-shift-left Opcodes/LSHL + ^:private compile-bit-shift-right Opcodes/LSHR + ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR + ) + +(defn ^:private compile-lux-== [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?left) + _ (compile ?right) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IF_ACMPEQ $then) + ;; else + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + _ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-nat-add Opcodes/LADD + ^:private compile-nat-sub Opcodes/LSUB + ^:private compile-nat-mul Opcodes/LMUL + + ^:private compile-deg-add Opcodes/LADD + ^:private compile-deg-sub Opcodes/LSUB + ^:private compile-deg-rem Opcodes/LSUB + ^:private compile-deg-scale Opcodes/LMUL + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + (&&/wrap-long))]] + (return nil))) + + ^:private compile-nat-div "div_nat" + ^:private compile-nat-rem "rem_nat" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-nat-eq 0 + + ^:private compile-deg-eq 0 + ^:private compile-deg-lt -1 + ) + +(defn ^:private compile-nat-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + + )]] + (return nil))) + + ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] + (return nil))) + + (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] + (return nil))))) + + ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" + ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-deg-mul "mul_deg" + ^:private compile-deg-div "div_deg" + ) + +(do-template [ ] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) + )]] + (return nil)))) + + ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double + ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long + ) + +(let [widen (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/I2L))) + shrink (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/L2I) + (.visitInsn Opcodes/I2C)))] + (do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + + )]] + (return nil))) + + ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink + ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen + )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x)] + (return nil))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-host [compile proc-category proc-name ?values special-args] + (case proc-category + "lux" + (case proc-name + "==" (compile-lux-== compile ?values special-args)) + + "bit" + (case proc-name + "count" (compile-bit-count compile ?values special-args) + "and" (compile-bit-and compile ?values special-args) + "or" (compile-bit-or compile ?values special-args) + "xor" (compile-bit-xor compile ?values special-args) + "shift-left" (compile-bit-shift-left compile ?values special-args) + "shift-right" (compile-bit-shift-right compile ?values special-args) + "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + "array" + (case proc-name + "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + "encode" (compile-deg-encode compile ?values special-args) + "decode" (compile-deg-decode compile ?values special-args) + "max-value" (compile-deg-max-value compile ?values special-args) + "min-value" (compile-deg-min-value compile ?values special-args) + "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "int" + (case proc-name + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "real" + (case proc-name + "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + "char" + (case proc-name + "to-nat" (compile-char-to-nat compile ?values special-args) + ) + + "jvm" + (case proc-name + "synchronized" (compile-jvm-synchronized compile ?values special-args) + "load-class" (compile-jvm-load-class compile ?values special-args) + "instanceof" (compile-jvm-instanceof compile ?values special-args) + "try" (compile-jvm-try compile ?values special-args) + "new" (compile-jvm-new compile ?values special-args) + "invokestatic" (compile-jvm-invokestatic compile ?values special-args) + "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) + "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) + "invokespecial" (compile-jvm-invokespecial compile ?values special-args) + "getstatic" (compile-jvm-getstatic compile ?values special-args) + "getfield" (compile-jvm-getfield compile ?values special-args) + "putstatic" (compile-jvm-putstatic compile ?values special-args) + "putfield" (compile-jvm-putfield compile ?values special-args) + "throw" (compile-jvm-throw compile ?values special-args) + "null?" (compile-jvm-null? compile ?values special-args) + "null" (compile-jvm-null compile ?values special-args) + "anewarray" (compile-jvm-anewarray compile ?values special-args) + "aaload" (compile-jvm-aaload compile ?values special-args) + "aastore" (compile-jvm-aastore compile ?values special-args) + "arraylength" (compile-jvm-arraylength compile ?values special-args) + "znewarray" (compile-jvm-znewarray compile ?values special-args) + "bnewarray" (compile-jvm-bnewarray compile ?values special-args) + "snewarray" (compile-jvm-snewarray compile ?values special-args) + "inewarray" (compile-jvm-inewarray compile ?values special-args) + "lnewarray" (compile-jvm-lnewarray compile ?values special-args) + "fnewarray" (compile-jvm-fnewarray compile ?values special-args) + "dnewarray" (compile-jvm-dnewarray compile ?values special-args) + "cnewarray" (compile-jvm-cnewarray compile ?values special-args) + "iadd" (compile-jvm-iadd compile ?values special-args) + "isub" (compile-jvm-isub compile ?values special-args) + "imul" (compile-jvm-imul compile ?values special-args) + "idiv" (compile-jvm-idiv compile ?values special-args) + "irem" (compile-jvm-irem compile ?values special-args) + "ieq" (compile-jvm-ieq compile ?values special-args) + "ilt" (compile-jvm-ilt compile ?values special-args) + "igt" (compile-jvm-igt compile ?values special-args) + "ceq" (compile-jvm-ceq compile ?values special-args) + "clt" (compile-jvm-clt compile ?values special-args) + "cgt" (compile-jvm-cgt compile ?values special-args) + "ladd" (compile-jvm-ladd compile ?values special-args) + "lsub" (compile-jvm-lsub compile ?values special-args) + "lmul" (compile-jvm-lmul compile ?values special-args) + "ldiv" (compile-jvm-ldiv compile ?values special-args) + "lrem" (compile-jvm-lrem compile ?values special-args) + "leq" (compile-jvm-leq compile ?values special-args) + "llt" (compile-jvm-llt compile ?values special-args) + "lgt" (compile-jvm-lgt compile ?values special-args) + "fadd" (compile-jvm-fadd compile ?values special-args) + "fsub" (compile-jvm-fsub compile ?values special-args) + "fmul" (compile-jvm-fmul compile ?values special-args) + "fdiv" (compile-jvm-fdiv compile ?values special-args) + "frem" (compile-jvm-frem compile ?values special-args) + "feq" (compile-jvm-feq compile ?values special-args) + "flt" (compile-jvm-flt compile ?values special-args) + "fgt" (compile-jvm-fgt compile ?values special-args) + "dadd" (compile-jvm-dadd compile ?values special-args) + "dsub" (compile-jvm-dsub compile ?values special-args) + "dmul" (compile-jvm-dmul compile ?values special-args) + "ddiv" (compile-jvm-ddiv compile ?values special-args) + "drem" (compile-jvm-drem compile ?values special-args) + "deq" (compile-jvm-deq compile ?values special-args) + "dlt" (compile-jvm-dlt compile ?values special-args) + "dgt" (compile-jvm-dgt compile ?values special-args) + "iand" (compile-jvm-iand compile ?values special-args) + "ior" (compile-jvm-ior compile ?values special-args) + "ixor" (compile-jvm-ixor compile ?values special-args) + "ishl" (compile-jvm-ishl compile ?values special-args) + "ishr" (compile-jvm-ishr compile ?values special-args) + "iushr" (compile-jvm-iushr compile ?values special-args) + "land" (compile-jvm-land compile ?values special-args) + "lor" (compile-jvm-lor compile ?values special-args) + "lxor" (compile-jvm-lxor compile ?values special-args) + "lshl" (compile-jvm-lshl compile ?values special-args) + "lshr" (compile-jvm-lshr compile ?values special-args) + "lushr" (compile-jvm-lushr compile ?values special-args) + "d2f" (compile-jvm-d2f compile ?values special-args) + "d2i" (compile-jvm-d2i compile ?values special-args) + "d2l" (compile-jvm-d2l compile ?values special-args) + "f2d" (compile-jvm-f2d compile ?values special-args) + "f2i" (compile-jvm-f2i compile ?values special-args) + "f2l" (compile-jvm-f2l compile ?values special-args) + "i2b" (compile-jvm-i2b compile ?values special-args) + "i2c" (compile-jvm-i2c compile ?values special-args) + "i2d" (compile-jvm-i2d compile ?values special-args) + "i2f" (compile-jvm-i2f compile ?values special-args) + "i2l" (compile-jvm-i2l compile ?values special-args) + "i2s" (compile-jvm-i2s compile ?values special-args) + "l2d" (compile-jvm-l2d compile ?values special-args) + "l2f" (compile-jvm-l2f compile ?values special-args) + "l2i" (compile-jvm-l2i compile ?values special-args) + "l2s" (compile-jvm-l2s compile ?values special-args) + "l2b" (compile-jvm-l2b compile ?values special-args) + "c2b" (compile-jvm-c2b compile ?values special-args) + "c2s" (compile-jvm-c2s compile ?values special-args) + "c2i" (compile-jvm-c2i compile ?values special-args) + "c2l" (compile-jvm-c2l compile ?values special-args) + "s2l" (compile-jvm-s2l compile ?values special-args) + "b2l" (compile-jvm-b2l compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/lambda.clj b/luxc/src/lux/compiler/jvm/lambda.clj new file mode 100644 index 000000000..87d977012 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/lambda.clj @@ -0,0 +1,281 @@ +(ns lux.compiler.jvm.lambda + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + (lux.compiler.jvm [base :as &&])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) + +;; [Utils] +(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) +(def ^:private -return "V") + +(defn ^:private ^String reset-signature [function-class] + (str "()" (&host-generics/->type-signature function-class))) + +(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) + +(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] + (doto method-writer + (.visitLdcInsn (int by)) + (.visitInsn Opcodes/IADD))) + +(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] + (doto method-writer + (.visitVarInsn Opcodes/ALOAD 0) + value-thunk + (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) + +(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] + (doto method-writer + (-> (.visitInsn Opcodes/ACONST_NULL) + (->> (dotimes [_ amount]))))) + +(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] + (doto method-writer + (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) + (->> (dotimes [idx amount]))))) + +(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] + (let [max-args-num (min amount &&/num-apply-variants)] + (doto method-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (consecutive-args start max-args-num) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) + (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) + (->> (when (> amount &&/num-apply-variants))))))) + +(defn ^:private lambda-impl-signature [arity] + (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) + +(defn ^:private lambda--signature [env arity] + (if (> arity 1) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" + -return) + (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" + -return))) + +(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] + (if (= 1 arity) + (doto method-writer + (.visitLdcInsn (int 0)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) + (doto method-writer + (.visitVarInsn Opcodes/ILOAD (inc closure-length)) + (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) + +(defn ^:private add-lambda- [^ClassWriter class class-name arity env] + (let [closure-length (&/|length env)] + (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) + (.visitCode) + ;; Do normal object initialization + (.visitVarInsn Opcodes/ALOAD 0) + (init-function arity closure-length) + ;; Add all of the closure variables + (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) + (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) + (doseq [?name+?captured (&/->seq env)]))) + ;; Add all the partial arguments + (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) + (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) + (dotimes [idx* (dec arity)]))) + ;; Finish + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))))) + +(defn ^:private instance-closure [compile lambda-class arity closed-over] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW lambda-class) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [?name+?captured] + (|case ?name+?captured + [?name [_ (&o/$captured _ _ ?source)]] + (compile nil ?source))) + closed-over) + :let [_ (when (> arity 1) + (doto *writer* + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity))))] + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] + (return nil))) + +(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] + (if (> arity 1) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + (.visitLdcInsn (int 0)) + (fill-nulls! (dec arity)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))) + +(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] + (if (> arity 1) + (let [num-partials (dec arity) + $default (new Label) + $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) + $labels (vec (concat $labels* (list $default))) + $end (new Label) + method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) + frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) + frame-stack (to-array [Opcodes/INTEGER]) + arity-over-extent (- arity +degree+)] + (do (doto method-writer + (.visitCode) + get-num-partials! + (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) + ;; (< stage (- arity +degree+)) + (-> (doto (.visitLabel $label) + (.visitTypeInsn Opcodes/NEW class-name) + (.visitInsn Opcodes/DUP) + (-> (get-field! class-name (str &&/closure-prefix cidx)) + (->> (dotimes [cidx (&/|length env)]))) + get-num-partials! + (inc-int! +degree+) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (fill-nulls! (- (- num-partials +degree+) stage)) + (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + (->> (cond (= stage arity-over-extent) + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (->> (when (not= 0 stage)))) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 +degree+) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (.visitJumpInsn Opcodes/GOTO $end)) + + (> stage arity-over-extent) + (let [args-to-completion (- arity stage) + args-left (- +degree+ args-to-completion)] + (doto method-writer + (.visitLabel $label) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) + (-> (get-field! class-name (str &&/partial-prefix idx)) + (->> (dotimes [idx stage]))) + (consecutive-args 1 args-to-completion) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) + (consecutive-applys (+ 1 args-to-completion) args-left) + (.visitJumpInsn Opcodes/GOTO $end))) + + :else) + (doseq [[stage $label] (map vector (range arity) $labels)]))) + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (return nil))) + (let [$begin (new Label)] + (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) + (.visitCode) + (.visitLabel $begin)) + (|do [^MethodVisitor *writer* &/get-writer + ret (compile $begin impl-body) + :let [_ (doto *writer* + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret)))) + )) + +;; [Exports] +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] + (|do [[file-name _ _] &/cursor + :let [??scope (&/|reverse ?scope) + name (&host/location (&/|tail ??scope)) + class-name (str (&host/->module-class (&/|head ??scope)) "/" name) + [^ClassWriter =class save?] (|case ?prev-writer + (&/$Some _writer) + (&/T [_writer false]) + + (&/$None) + (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version lambda-flags + class-name nil &&/function-class (into-array String []))) + true])) + _ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) + (doto (.visitEnd))) + (-> (doto (.visitField datum-flags captured-name field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) + (doto (.visitEnd)) + (->> (dotimes [idx (dec arity)]))) + (-> (.visitSource file-name nil) + (when save?)) + (add-lambda- class-name arity ?env) + (add-lambda-reset class-name arity ?env) + )] + _ (if (> arity 1) + (add-lambda-impl =class class-name compile arity ?body) + (return nil)) + _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) + (&/|range* 1 (min arity &&/num-apply-variants))) + :let [_ (.visitEnd =class)] + _ (if save? + (&&/save-class! name (.toByteArray =class)) + (return nil))] + (if save? + (instance-closure compile class-name arity ?env) + (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj new file mode 100644 index 000000000..591e490c4 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -0,0 +1,493 @@ +(ns lux.compiler.jvm.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler.jvm [base :as &&] + [lambda :as &&lambda])) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor) + java.lang.reflect.Field)) + +;; [Exports] +(defn compile-bool [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] + (return nil))) + +(do-template [ ] + (defn [value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))]] + (return nil))) + + compile-nat "java/lang/Long" "J" long + compile-int "java/lang/Long" "J" long + compile-deg "java/lang/Long" "J" long + compile-real "java/lang/Double" "D" double + compile-char "java/lang/Character" "C" char + ) + +(defn compile-text [?value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* ?value)]] + (return nil))) + +(defn compile-tuple [compile ?elems] + (|do [^MethodVisitor *writer* &/get-writer + :let [num-elems (&/|length ?elems)]] + (|case num-elems + 0 + (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] + (return nil)) + + 1 + (compile (&/|head ?elems)) + + _ + (|do [:let [_ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] + (return nil))))) + +(defn compile-variant [compile tag tail? value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitLdcInsn *writer* (int tag)) + _ (if tail? + (.visitLdcInsn *writer* "") + (.visitInsn *writer* Opcodes/ACONST_NULL))] + _ (compile value) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] + (return nil))) + +(defn compile-local [compile ?idx] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] + (return nil))) + +(defn compile-captured [compile ?scope ?captured-id ?source] + (|do [:let [??scope (&/|reverse ?scope)] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD + (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) + (str &&/closure-prefix ?captured-id) + "Ljava/lang/Object;"))]] + (return nil))) + +(defn compile-global [compile ?owner-class ?name] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] + (return nil))) + +(defn ^:private compile-apply* [compile ?args] + (|do [^MethodVisitor *writer* &/get-writer + _ (&/map% (fn [?args] + (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] + _ (&/map% compile ?args) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] + (return nil))) + (&/|partition &&/num-apply-variants ?args))] + (return nil))) + +(defn compile-apply [compile ?fn ?args] + (|case ?fn + [_ (&o/$var (&/$Global ?module ?name))] + (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) + class-loader &/loader + :let [func-class (class func-obj) + func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) + func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) + num-args (&/|length ?args) + func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] + (if (and (= 0 func-partials) + (>= num-args func-arity)) + (|do [_ (compile ?fn) + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] + _ (&/map% compile (&/|take func-arity ?args)) + :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] + _ (if (= num-args func-arity) + (return nil) + (compile-apply* compile (&/|drop func-arity ?args)))] + (return nil)) + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)))) + + _ + (|do [_ (compile ?fn)] + (compile-apply* compile ?args)) + )) + +(defn compile-loop [compile-expression register-offset inits body] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) + inits)] + _ (&/map% (fn [idx+_init] + (|do [:let [[idx _init] idx+_init + idx+ (+ register-offset idx)] + _ (compile-expression nil _init) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] + (return nil))) + idxs+inits) + :let [$begin (new Label) + _ (.visitLabel *writer* $begin)]] + (compile-expression $begin body) + )) + +(defn compile-iter [compile $begin register-offset ?args] + (|do [^MethodVisitor *writer* &/get-writer + :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) + ?args)] + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)]] + (if already-set? + (return nil) + (compile ?arg)))) + idxs+args) + _ (&/map% (fn [idx+?arg] + (|do [:let [[idx ?arg] idx+?arg + idx+ (+ register-offset idx) + already-set? (|case ?arg + [_ (&o/$var (&/$Local l-idx))] + (= idx+ l-idx) + + _ + false)] + :let [_ (when (not already-set?) + (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] + (return nil))) + (&/|reverse idxs+args)) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] + (return nil))) + +(defn compile-let [compile _value _register _body] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] + _ (compile _body)] + (return nil))) + +(defn compile-record-get [compile _value _path] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _value) + :let [_ (&/|map (fn [step] + (|let [[idx tail?] step] + (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLdcInsn (int idx)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" + (if tail? "product_getRight" "product_getLeft") + "([Ljava/lang/Object;I)Ljava/lang/Object;")))) + _path)]] + (return nil))) + +(defn compile-if [compile _test _then _else] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile _test) + :let [$else (new Label) + $end (new Label) + _ (doto *writer* + &&/unwrap-boolean + (.visitJumpInsn Opcodes/IFEQ $else))] + _ (compile _then) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] + :let [_ (.visitLabel *writer* $else)] + _ (compile _else) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) + _ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private de-ann [optim] + (|case optim + [_ (&o/$ann value-expr _)] + value-expr + + _ + optim)) + +(defn ^:private throwable->text [^Throwable t] + (let [base (->> t + .getStackTrace + (map str) + (cons (.getMessage t)) + (interpose "\n") + (apply str))] + (if-let [cause (.getCause t)] + (str base "\n\n" "Caused by: " (throwable->text cause)) + base))) + +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body ?meta] + (|do [module-name &/get-module-name + class-loader &/loader] + (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) + (&/$Some (&/$IdentA [r-module r-name])) + (if (= 1 (&/|length ?meta)) + (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) + def-class (&&/load-class! class-loader current-class) + def-meta ?meta + def-value (-> def-class (.getField &/value-field) (.get nil))] + def-type (&a-module/def-type r-module r-name) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value))] + (return nil)) + (&/fail-with-loc (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) + + (&/$Some _) + (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") + + _ + (|case (de-ann ?body) + [_ (&o/$function _ _ __scope _ _)] + (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope + false + (de-ann ?body))] + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil &&/function-class (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ instancer + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolA true)) + true + + _ + false) + def-meta ?meta] + def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) + (catch Throwable t + (&/assert! "Error during value initialization." (throwable->text t)))) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListA tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextA tag) + (return tag) + + _ + (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + + _ + (|do [:let [=value-type (&a/expr-type* ?body)] + [file-name _ _] &/cursor + :let [datum-sig "Ljava/lang/Object;" + def-name (&host/def-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version class-flags + current-class nil "java/lang/Object" (into-array String [])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/value-field datum-sig nil nil) + (doto (.visitEnd))) + (.visitSource file-name nil))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile nil ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd =class)] + _ (&&/save-class! def-name (.toByteArray =class)) + :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) + def-type (&a/expr-type* ?body) + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) + (&/$Some (&/$BoolA true)) + true + + _ + false) + def-meta ?meta] + def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) + (catch Throwable t + (&/assert! "Error during value initialization." (throwable->text t)))) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListA tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextA tag) + (return tag) + + _ + (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil))) + )))) + +(defn compile-program [compile ?body] + (|do [module-name &/get-module-name + ^ClassWriter *writer* &/get-writer] + (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) + (.visitCode)) + (|do [^MethodVisitor main-writer &/get-writer + :let [$loop (new Label) + $end (new Label) + _ (doto main-writer + ;; Tail: Begin + (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V + ;; Tail: End + ;; Size: Begin + (.visitVarInsn Opcodes/ALOAD 0) ;; VA + (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; Size: End + ;; Loop: Begin + (.visitLabel $loop) + (.visitLdcInsn (int 1)) ;; VII + (.visitInsn Opcodes/ISUB) ;; VI + (.visitInsn Opcodes/DUP) ;; VII + (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; Head: Begin + (.visitInsn Opcodes/DUP) ;; VII + (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + (.visitInsn Opcodes/SWAP) ;; VIAI + (.visitInsn Opcodes/AALOAD) ;; VIO + (.visitInsn Opcodes/SWAP) ;; VOI + (.visitInsn Opcodes/DUP_X2) ;; IVOI + (.visitInsn Opcodes/POP) ;; IVO + ;; Head: End + ;; Tuple: Begin + (.visitLdcInsn (int 2)) ;; IVOS + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + (.visitInsn Opcodes/SWAP) ;; IV22O + (.visitLdcInsn (int 0)) ;; IV22OI + (.visitInsn Opcodes/SWAP) ;; IV22IO + (.visitInsn Opcodes/AASTORE) ;; IV2 + (.visitInsn Opcodes/DUP_X1) ;; I2V2 + (.visitInsn Opcodes/SWAP) ;; I22V + (.visitLdcInsn (int 1)) ;; I22VI + (.visitInsn Opcodes/SWAP) ;; I22IV + (.visitInsn Opcodes/AASTORE) ;; I2 + ;; Tuple: End + ;; Cons: Begin + (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I + (.visitLdcInsn "") ;; I2I? + (.visitInsn Opcodes/DUP2_X1) ;; II?2I? + (.visitInsn Opcodes/POP2) ;; II?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV + ;; Cons: End + (.visitInsn Opcodes/SWAP) ;; VI + (.visitJumpInsn Opcodes/GOTO $loop) + ;; Loop: End + (.visitLabel $end) ;; VI + (.visitInsn Opcodes/POP) ;; V + (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + ) + ] + _ (compile ?body) + :let [_ (doto main-writer + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (doto main-writer + (.visitInsn Opcodes/POP) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) diff --git a/luxc/src/lux/compiler/lambda.clj b/luxc/src/lux/compiler/lambda.clj deleted file mode 100644 index 006476bef..000000000 --- a/luxc/src/lux/compiler/lambda.clj +++ /dev/null @@ -1,281 +0,0 @@ -(ns lux.compiler.lambda - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - (lux.compiler [base :as &&])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private lambda-return-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private -return "V") - -(defn ^:private ^String reset-signature [function-class] - (str "()" (&host-generics/->type-signature function-class))) - -(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) - -(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] - (doto method-writer - (.visitLdcInsn (int by)) - (.visitInsn Opcodes/IADD))) - -(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - value-thunk - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] - (doto method-writer - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ amount]))))) - -(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] - (doto method-writer - (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) - (->> (dotimes [idx amount]))))) - -(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] - (let [max-args-num (min amount &&/num-apply-variants)] - (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start max-args-num) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) - (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) - (->> (when (> amount &&/num-apply-variants))))))) - -(defn ^:private lambda-impl-signature [arity] - (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" lambda-return-sig)) - -(defn ^:private lambda--signature [env arity] - (if (> arity 1) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" - -return) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" - -return))) - -(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] - (if (= 1 arity) - (doto method-writer - (.visitLdcInsn (int 0)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) - (doto method-writer - (.visitVarInsn Opcodes/ILOAD (inc closure-length)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) - -(defn ^:private add-lambda- [^ClassWriter class class-name arity env] - (let [closure-length (&/|length env)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (lambda--signature env arity) nil nil) - (.visitCode) - ;; Do normal object initialization - (.visitVarInsn Opcodes/ALOAD 0) - (init-function arity closure-length) - ;; Add all of the closure variables - (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) - (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) - (doseq [?name+?captured (&/->seq env)]))) - ;; Add all the partial arguments - (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) - (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) - (dotimes [idx* (dec arity)]))) - ;; Finish - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] - (defn ^:private add-lambda-impl [^ClassWriter class class-name compile arity impl-body] - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod class impl-flags "impl" (lambda-impl-signature arity) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))))) - -(defn ^:private instance-closure [compile lambda-class arity closed-over] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW lambda-class) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [?name+?captured] - (|case ?name+?captured - [?name [_ (&o/$captured _ _ ?source)]] - (compile nil ?source))) - closed-over) - :let [_ (when (> arity 1) - (doto *writer* - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity))))] - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" (lambda--signature closed-over arity))]] - (return nil))) - -(defn ^:private add-lambda-reset [^ClassWriter class-writer class-name arity env] - (if (> arity 1) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(defn ^:private add-lambda-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] - (if (> arity 1) - (let [num-partials (dec arity) - $default (new Label) - $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) - $labels (vec (concat $labels* (list $default))) - $end (new Label) - method-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature +degree+) nil nil) - frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) - frame-stack (to-array [Opcodes/INTEGER]) - arity-over-extent (- arity +degree+)] - (do (doto method-writer - (.visitCode) - get-num-partials! - (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) - ;; (< stage (- arity +degree+)) - (-> (doto (.visitLabel $label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - get-num-partials! - (inc-int! +degree+) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (fill-nulls! (- (- num-partials +degree+) stage)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (lambda--signature env arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - (->> (cond (= stage arity-over-extent) - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (->> (when (not= 0 stage)))) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (.visitJumpInsn Opcodes/GOTO $end)) - - (> stage arity-over-extent) - (let [args-to-completion (- arity stage) - args-left (- +degree+ args-to-completion)] - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (lambda-impl-signature arity)) - (consecutive-applys (+ 1 args-to-completion) args-left) - (.visitJumpInsn Opcodes/GOTO $end))) - - :else) - (doseq [[stage $label] (map vector (range arity) $labels)]))) - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (return nil))) - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature 1) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) - )) - -;; [Exports] -(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] - (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] - (|do [[file-name _ _] &/cursor - :let [??scope (&/|reverse ?scope) - name (&host/location (&/|tail ??scope)) - class-name (str (&host/->module-class (&/|head ??scope)) "/" name) - [^ClassWriter =class save?] (|case ?prev-writer - (&/$Some _writer) - (&/T [_writer false]) - - (&/$None) - (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version lambda-flags - class-name nil &&/function-class (into-array String []))) - true])) - _ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) - (doto (.visitEnd))) - (-> (doto (.visitField datum-flags captured-name field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) - (doto (.visitEnd)) - (->> (dotimes [idx (dec arity)]))) - (-> (.visitSource file-name nil) - (when save?)) - (add-lambda- class-name arity ?env) - (add-lambda-reset class-name arity ?env) - )] - _ (if (> arity 1) - (add-lambda-impl =class class-name compile arity ?body) - (return nil)) - _ (&/map% #(add-lambda-apply-n =class % class-name arity ?env compile ?body) - (&/|range* 1 (min arity &&/num-apply-variants))) - :let [_ (.visitEnd =class)] - _ (if save? - (&&/save-class! name (.toByteArray =class)) - (return nil))] - (if save? - (instance-closure compile class-name arity ?env) - (return (instance-closure compile class-name arity ?env)))))) diff --git a/luxc/src/lux/compiler/lux.clj b/luxc/src/lux/compiler/lux.clj deleted file mode 100644 index 36d923e60..000000000 --- a/luxc/src/lux/compiler/lux.clj +++ /dev/null @@ -1,493 +0,0 @@ -(ns lux.compiler.lux - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler [base :as &&] - [lambda :as &&lambda])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - java.lang.reflect.Field)) - -;; [Exports] -(defn compile-bool [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] - (return nil))) - -(do-template [ ] - (defn [value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))]] - (return nil))) - - compile-nat "java/lang/Long" "J" long - compile-int "java/lang/Long" "J" long - compile-deg "java/lang/Long" "J" long - compile-real "java/lang/Double" "D" double - compile-char "java/lang/Character" "C" char - ) - -(defn compile-text [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* ?value)]] - (return nil))) - -(defn compile-tuple [compile ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems)]] - (|case num-elems - 0 - (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] - (return nil)) - - 1 - (compile (&/|head ?elems)) - - _ - (|do [:let [_ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] - (return nil))))) - -(defn compile-variant [compile tag tail? value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* (int tag)) - _ (if tail? - (.visitLdcInsn *writer* "") - (.visitInsn *writer* Opcodes/ACONST_NULL))] - _ (compile value) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] - (return nil))) - -(defn compile-local [compile ?idx] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] - (return nil))) - -(defn compile-captured [compile ?scope ?captured-id ?source] - (|do [:let [??scope (&/|reverse ?scope)] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD - (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) - (str &&/closure-prefix ?captured-id) - "Ljava/lang/Object;"))]] - (return nil))) - -(defn compile-global [compile ?owner-class ?name] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] - (return nil))) - -(defn ^:private compile-apply* [compile ?args] - (|do [^MethodVisitor *writer* &/get-writer - _ (&/map% (fn [?args] - (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] - _ (&/map% compile ?args) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] - (return nil))) - (&/|partition &&/num-apply-variants ?args))] - (return nil))) - -(defn compile-apply [compile ?fn ?args] - (|case ?fn - [_ (&o/$var (&/$Global ?module ?name))] - (|do [[_ [_ _ func-obj]] (&a-module/find-def ?module ?name) - class-loader &/loader - :let [func-class (class func-obj) - func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) - func-partials (.get ^Field (.getDeclaredField (Class/forName "lux.Function" true class-loader) &&/partials-field) func-obj) - num-args (&/|length ?args) - func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] - (if (and (= 0 func-partials) - (>= num-args func-arity)) - (|do [_ (compile ?fn) - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] - _ (&/map% compile (&/|take func-arity ?args)) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] - _ (if (= num-args func-arity) - (return nil) - (compile-apply* compile (&/|drop func-arity ?args)))] - (return nil)) - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)))) - - _ - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)) - )) - -(defn compile-loop [compile-expression register-offset inits body] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) - inits)] - _ (&/map% (fn [idx+_init] - (|do [:let [[idx _init] idx+_init - idx+ (+ register-offset idx)] - _ (compile-expression nil _init) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] - (return nil))) - idxs+inits) - :let [$begin (new Label) - _ (.visitLabel *writer* $begin)]] - (compile-expression $begin body) - )) - -(defn compile-iter [compile $begin register-offset ?args] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) - ?args)] - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)]] - (if already-set? - (return nil) - (compile ?arg)))) - idxs+args) - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)] - :let [_ (when (not already-set?) - (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] - (return nil))) - (&/|reverse idxs+args)) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] - (return nil))) - -(defn compile-let [compile _value _register _body] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] - _ (compile _body)] - (return nil))) - -(defn compile-record-get [compile _value _path] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (&/|map (fn [step] - (|let [[idx tail?] step] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int idx)) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" - (if tail? "product_getRight" "product_getLeft") - "([Ljava/lang/Object;I)Ljava/lang/Object;")))) - _path)]] - (return nil))) - -(defn compile-if [compile _test _then _else] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _test) - :let [$else (new Label) - $end (new Label) - _ (doto *writer* - &&/unwrap-boolean - (.visitJumpInsn Opcodes/IFEQ $else))] - _ (compile _then) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $else)] - _ (compile _else) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) - _ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private de-ann [optim] - (|case optim - [_ (&o/$ann value-expr _)] - value-expr - - _ - optim)) - -(defn ^:private throwable->text [^Throwable t] - (let [base (->> t - .getStackTrace - (map str) - (cons (.getMessage t)) - (interpose "\n") - (apply str))] - (if-let [cause (.getCause t)] - (str base "\n\n" "Caused by: " (throwable->text cause)) - base))) - -(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body ?meta] - (|do [module-name &/get-module-name - class-loader &/loader] - (|case (&a-meta/meta-get &a-meta/alias-tag ?meta) - (&/$Some (&/$IdentA [r-module r-name])) - (if (= 1 (&/|length ?meta)) - (|do [:let [current-class (&host-generics/->class-name (str (&host/->module-class r-module) "/" (&host/def-name r-name))) - def-class (&&/load-class! class-loader current-class) - def-meta ?meta - def-value (-> def-class (.getField &/value-field) (.get nil))] - def-type (&a-module/def-type r-module r-name) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value))] - (return nil)) - (&/fail-with-loc (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) - - (&/$Some _) - (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") - - _ - (|case (de-ann ?body) - [_ (&o/$function _ _ __scope _ _)] - (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope - false - (de-ann ?body))] - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil &&/function-class (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - instancer (&&lambda/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ instancer - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body) - is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolA true)) - true - - _ - false) - def-meta ?meta] - def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) - (catch Throwable t - (&/assert! "Error during value initialization." (throwable->text t)))) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value)) - _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) - [true (&/$Some (&/$ListA tags*))] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - (&/$TextA tag) - (return tag) - - _ - (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Can't define tags for non-type.") - - [true (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)) - :let [_ (println 'DEF (str module-name ";" ?name))]] - (return nil))) - - _ - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil "java/lang/Object" (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile nil ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body) - is-type? (|case (&a-meta/meta-get &a-meta/type?-tag ?meta) - (&/$Some (&/$BoolA true)) - true - - _ - false) - def-meta ?meta] - def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) - (catch Throwable t - (&/assert! "Error during value initialization." (throwable->text t)))) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value)) - _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) - [true (&/$Some (&/$ListA tags*))] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - (&/$TextA tag) - (return tag) - - _ - (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Can't define tags for non-type.") - - [true (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)) - :let [_ (println 'DEF (str module-name ";" ?name))]] - (return nil))) - )))) - -(defn compile-program [compile ?body] - (|do [module-name &/get-module-name - ^ClassWriter *writer* &/get-writer] - (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) - (.visitCode)) - (|do [^MethodVisitor main-writer &/get-writer - :let [$loop (new Label) - $end (new Label) - _ (doto main-writer - ;; Tail: Begin - (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V - ;; Tail: End - ;; Size: Begin - (.visitVarInsn Opcodes/ALOAD 0) ;; VA - (.visitInsn Opcodes/ARRAYLENGTH) ;; VI - ;; Size: End - ;; Loop: Begin - (.visitLabel $loop) - (.visitLdcInsn (int 1)) ;; VII - (.visitInsn Opcodes/ISUB) ;; VI - (.visitInsn Opcodes/DUP) ;; VII - (.visitJumpInsn Opcodes/IFLT $end) ;; VI - ;; Head: Begin - (.visitInsn Opcodes/DUP) ;; VII - (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA - (.visitInsn Opcodes/SWAP) ;; VIAI - (.visitInsn Opcodes/AALOAD) ;; VIO - (.visitInsn Opcodes/SWAP) ;; VOI - (.visitInsn Opcodes/DUP_X2) ;; IVOI - (.visitInsn Opcodes/POP) ;; IVO - ;; Head: End - ;; Tuple: Begin - (.visitLdcInsn (int 2)) ;; IVOS - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 - (.visitInsn Opcodes/DUP_X1) ;; IV2O2 - (.visitInsn Opcodes/SWAP) ;; IV22O - (.visitLdcInsn (int 0)) ;; IV22OI - (.visitInsn Opcodes/SWAP) ;; IV22IO - (.visitInsn Opcodes/AASTORE) ;; IV2 - (.visitInsn Opcodes/DUP_X1) ;; I2V2 - (.visitInsn Opcodes/SWAP) ;; I22V - (.visitLdcInsn (int 1)) ;; I22VI - (.visitInsn Opcodes/SWAP) ;; I22IV - (.visitInsn Opcodes/AASTORE) ;; I2 - ;; Tuple: End - ;; Cons: Begin - (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I - (.visitLdcInsn "") ;; I2I? - (.visitInsn Opcodes/DUP2_X1) ;; II?2I? - (.visitInsn Opcodes/POP2) ;; II?2 - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV - ;; Cons: End - (.visitInsn Opcodes/SWAP) ;; VI - (.visitJumpInsn Opcodes/GOTO $loop) - ;; Loop: End - (.visitLabel $end) ;; VI - (.visitInsn Opcodes/POP) ;; V - (.visitVarInsn Opcodes/ASTORE (int 0)) ;; - ) - ] - _ (compile ?body) - :let [_ (doto main-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) diff --git a/luxc/src/lux/compiler/module.clj b/luxc/src/lux/compiler/module.clj deleted file mode 100644 index 9ca4e040b..000000000 --- a/luxc/src/lux/compiler/module.clj +++ /dev/null @@ -1,23 +0,0 @@ -(ns lux.compiler.module - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type]) - [lux.analyser.module :as &module])) - -;; [Exports] -(def tag-groups - "(Lux (List (, Text (List Text))))" - (|do [module &/get-current-module] - (return (&/|map (fn [pair] - (|case pair - [name [tags exported? _]] - (&/T [name (&/|map (fn [tag] - (|let [[t-prefix t-name] tag] - t-name)) - tags)]))) - (&/get$ &module/$types module))) - )) diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj index 22c2f47d2..7562aaf70 100644 --- a/luxc/src/lux/repl.clj +++ b/luxc/src/lux/repl.clj @@ -6,7 +6,7 @@ [analyser :as &analyser] [optimizer :as &optimizer] [compiler :as &compiler]) - [lux.compiler.cache :as &cache] + [lux.compiler.jvm.cache :as &cache] [lux.analyser.base :as &a-base] [lux.analyser.lux :as &a-lux] [lux.analyser.module :as &module]) -- cgit v1.2.3 From 97d1a9d0c5b469c3de4e9ee8af33e5a9d3144cb6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 17:35:20 -0400 Subject: - More refactorings. - Changed the place where module-compilation-state was being stored. - No longer keeping the compiler's name as part of the compiler's state. --- luxc/src/lux/analyser.clj | 3 +- luxc/src/lux/analyser/lux.clj | 30 +++++++-------- luxc/src/lux/analyser/module.clj | 43 +++++++++++++++++++-- luxc/src/lux/base.clj | 76 ++----------------------------------- luxc/src/lux/compiler/jvm.clj | 37 ++++++++++++++++-- luxc/src/lux/compiler/jvm/cache.clj | 4 +- luxc/src/lux/compiler/jvm/lux.clj | 6 +-- 7 files changed, 98 insertions(+), 101 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 614bc0a34..50edefac4 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -59,7 +59,8 @@ (defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) [cursor token] ?token - [compile-def compile-program compile-class compile-interface] compilers] + compile-def (aget compilers 0) + compile-program (aget compilers 1)] (|case token ;; Standard special forms (&/$BoolS ?value) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index 5f3626900..27f4ee11e 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -560,7 +560,7 @@ module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? - (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) + (&/fail-with-loc (str "[Analyser Error] Can't re-define " (str module-name ";" ?name))) (|do [=value (&/without-repl-closure (&/with-scope ?name (&&/analyse-1+ analyse ?value))) @@ -572,24 +572,23 @@ (return &/$Nil)) ))) -(defn ^:private merge-hosts +(defn ^:private merge-module-states "(-> Host Host Host)" [new old] - (|let [merged-module-states (&/fold (fn [total m-state] - (|let [[_name _state] m-state] - (|case _state - (&/$Cached) - (&/|put _name _state total) + (|let [merged-module-states (&/fold (fn [total new-module] + (|let [[_name _module] new-module] + (|case (&/get$ &&module/$module-state _module) + (&&module/$Cached) + (&/|put _name _module total) - (&/$Compiled) - (&/|put _name _state total) + (&&module/$Compiled) + (&/|put _name _module total) _ total))) - (&/get$ &/$module-states old) - (&/get$ &/$module-states new))] - (->> old - (&/set$ &/$module-states merged-module-states)))) + (&/get$ &/$modules old) + (&/get$ &/$modules new))] + (&/set$ &/$modules merged-module-states old))) (defn ^:private merge-modules "(-> Text Module Module Module)" @@ -618,8 +617,7 @@ (&/get$ &/$modules old))) (&/set$ &/$seed (max (&/get$ &/$seed new) (&/get$ &/$seed old))) - (&/set$ &/$host (merge-hosts (&/get$ &/$host new) - (&/get$ &/$host old))))) + (merge-module-states new))) (def ^:private get-compiler (fn [compiler] @@ -645,7 +643,7 @@ (&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path)) (return nil)) already-compiled? (&&module/exists? path) - active? (&/active-module? path) + active? (&&module/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module)) _ (&&module/add-import path) diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj index 3ccb887ff..9df1054c8 100644 --- a/luxc/src/lux/analyser/module.clj +++ b/luxc/src/lux/analyser/module.clj @@ -4,13 +4,20 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftuple |let |do return return* |case]] + (lux [base :as & :refer [defvariant deftuple |let |do return return* |case]] [type :as &type] [host :as &host]) [lux.host.generics :as &host-generics] (lux.analyser [meta :as &meta]))) ;; [Utils] +;; ModuleState +(defvariant + ("Active" 0) + ("Compiled" 0) + ("Cached" 0)) + +;; Module (deftuple ["module-hash" "module-aliases" @@ -18,7 +25,8 @@ "imports" "tags" "types" - "module-anns"]) + "module-anns" + "module-state"]) (defn ^:private new-module [hash] (&/T [;; lux;module-hash @@ -34,9 +42,38 @@ ;; "lux;types" (&/|table) ;; module-anns - (&/|list)] + (&/|list) + ;; "module-state" + $Active] )) +(do-template [ ] + (do (defn [module-name] + "(-> Text (Lux Unit))" + (fn [state] + (let [state* (&/update$ &/$modules + (fn [modules] + (&/|update module-name + (fn [=module] + (&/set$ $module-state =module)) + modules)) + state)] + (&/$Right (&/T [state* &/unit-tag]))))) + (defn [module-name] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module-name))] + (&/$Right (&/T [state (|case (&/get$ $module-state =module) + () true + _ false)])) + (&/$Right (&/T [state false]))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) + ;; [Exports] (defn add-import "(-> Text (Lux Null))" diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 9859db068..5e8c8c0d0 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -112,19 +112,12 @@ "locals" "closure"]) -;; ModuleState -(defvariant - ("Active" 0) - ("Compiled" 0) - ("Cached" 0)) - ;; Host (deftuple ["writer" "loader" "classes" "catching" - "module-states" "type-env" "dummy-mappings" ]) @@ -137,8 +130,7 @@ ("REPL" 0)) (deftuple - ["compiler-name" - "compiler-version" + ["compiler-version" "compiler-mode"]) (deftuple @@ -231,7 +223,6 @@ (def ^:const module-class-name "_") (def ^:const +name-separator+ ";") -(def ^:const ^String compiler-name "Lux/JVM") (def ^:const ^String compiler-version "0.6.0") ;; Constructors @@ -718,41 +709,10 @@ +init-bindings+] )) -(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String - (class (byte-array [])) - Integer/TYPE - Integer/TYPE])) - (.setAccessible true))] - (defn memory-class-loader [store] - (proxy [java.lang.ClassLoader] - [] - (findClass [^String class-name] - (if-let [^bytes bytecode (get @store class-name)] - (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) - (def loader (fn [state] (return* state (->> state (get$ $host) (get$ $loader))))) -(defn host [_] - (let [store (atom {})] - (T [;; "lux;writer" - $None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; "lux;catching" - $Nil - ;; "lux;module-states" - (|table) - ;; lux;type-env - (|table) - ;; lux;dummy-mappings - (|table) - ]))) - (defn with-no-catches [body] "(All [a] (-> (Lux a) (Lux a)))" (fn [state] @@ -765,15 +725,13 @@ (fail* msg))))) (defn default-compiler-info [mode] - (T [;; compiler-name - compiler-name - ;; compiler-version + (T [;; compiler-version compiler-version ;; compiler-mode mode] )) -(defn init-state [mode] +(defn init-state [mode host-data] (T [;; "lux;info" (default-compiler-info mode) ;; "lux;source" @@ -793,7 +751,7 @@ ;; scope-type-vars $Nil ;; "lux;host" - (host nil)] + host-data] )) (defn save-module [body] @@ -1342,32 +1300,6 @@ ($Some xs**) ($Some ($Cons x xs**))) ))) -(do-template [ ] - (do (defn [module] - "(-> Text (Lux Unit))" - (fn [state] - (let [state* (update$ $host (fn [host] - (update$ $module-states - (fn [module-states] - (|put module module-states)) - host)) - state)] - ($Right (T [state* unit-tag]))))) - (defn [module] - "(-> Text (Lux Bool))" - (fn [state] - (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] - ($Right (T [state (|case module-state - () true - _ false)])) - ($Right (T [state false]))) - ))) - - flag-active-module active-module? $Active - flag-compiled-module compiled-module? $Compiled - flag-cached-module cached-module? $Cached - ) - (do-template [ ] (defn [p xs] "(All [a] (-> (-> a Bool) (List a) Bool))" diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 5d787f5cd..bb333df57 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -178,7 +178,7 @@ (&/fail-with-loc "[Compiler Error] Can't re-define a module!") (|do [_ (&&cache/delete name) _ (&a-module/create-module name file-hash) - _ (&/flag-active-module name) + _ (&a-module/flag-active-module name) :let [module-class-name (str (&host/->module-class name) "/_") =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) @@ -199,7 +199,7 @@ (&/set$ &/$source (&reader/from name file-content) state)) (&/$Right ?state _) (&/run-state (|do [:let [_ (.visitEnd =class)] - _ (&/flag-compiled-module name) + _ (&a-module/flag-compiled-module name) _ (&&/save-class! &/module-class-name (.toByteArray =class)) module-descriptor &&core/generate-module-descriptor _ (&&core/write-module-descriptor! name module-descriptor)] @@ -211,12 +211,43 @@ ) ))) +(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String + (class (byte-array [])) + Integer/TYPE + Integer/TYPE])) + (.setAccessible true))] + (defn memory-class-loader [store] + (proxy [java.lang.ClassLoader] + [] + (findClass [^String class-name] + (if-let [^bytes bytecode (get @store class-name)] + (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) + (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name)))))))) + +(defn jvm-host [] + (let [store (atom {})] + (&/T [;; "lux;writer" + &/$None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; "lux;catching" + &/$Nil + ;; "lux;module-states" + (&/|table) + ;; lux;type-env + (&/|table) + ;; lux;dummy-mappings + (&/|table) + ]))) + (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs) _ (compile-module source-dirs "lux")] (compile-module source-dirs program-module))] - (|case (m-action (&/init-state mode)) + (|case (m-action (&/init-state mode (jvm-host))) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state)) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index 1746514bc..e75e09f1b 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -149,6 +149,7 @@ (defn ^:private install-module [loader module module-hash imports tag-groups module-anns def-entries] (|do [_ (&a-module/create-module module module-hash) + _ (&a-module/flag-cached-module module) _ (&a-module/set-anns module-anns module) _ (&a-module/set-imports imports) _ (&/map% (partial process-def-entry loader module) @@ -269,7 +270,6 @@ (defn load [module-name] "(-> Text (Lux Null))" (if-let [module-struct (get @!pre-loaded-cache module-name)] - (|do [_ (inject-module module-name module-struct) - _ (&/flag-cached-module module-name)] + (|do [_ (inject-module module-name module-struct)] (return nil)) (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj index 591e490c4..64760bbb6 100644 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -276,8 +276,7 @@ (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope false (de-ann ?body))] - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor + (|do [[file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&host/def-name ?name) current-class (str (&host/->module-class module-name) "/" def-name) @@ -347,8 +346,7 @@ (return nil))) _ - (|do [:let [=value-type (&a/expr-type* ?body)] - [file-name _ _] &/cursor + (|do [[file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&host/def-name ?name) current-class (str (&host/->module-class module-name) "/" def-name) -- cgit v1.2.3 From 3fa825d4ef98f2bdd9a31202bf04b06b9a1d9daa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Jan 2017 19:50:38 -0400 Subject: - The data for checking which exceptions are being catched has been moved from the host state to the normal compiler state. --- luxc/src/lux/analyser/jvm.clj | 7 +++---- luxc/src/lux/base.clj | 10 ++++++---- luxc/src/lux/compiler/jvm.clj | 2 -- 3 files changed, 9 insertions(+), 10 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj index 24d2b2017..5ea64d41a 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/jvm.clj @@ -25,7 +25,6 @@ (fn [state] (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) catching (->> state - (&/get$ &/$host) (&/get$ &/$catching) (&/|map #(Class/forName % true class-loader)))] (if-let [missing-ex (&/fold (fn [prev ^Class now] @@ -53,14 +52,14 @@ (defn ^:private with-catches [catches body] "(All [a] (-> (List Text) (Lux a) (Lux a)))" (fn [state] - (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] + (let [old-catches (&/get$ &/$catching state) + state* (&/update$ &/$catching (partial &/|++ catches) state)] (|case (&/run-state body state*) (&/$Left msg) (&/$Left msg) (&/$Right state** output) - (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + (&/$Right (&/T [(&/set$ &/$catching old-catches state**) output])))) )) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 5e8c8c0d0..6ab09166e 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -117,7 +117,6 @@ ["writer" "loader" "classes" - "catching" "type-env" "dummy-mappings" ]) @@ -143,6 +142,7 @@ "expected" "seed" "scope-type-vars" + "catching" "host"]) ;; Compiler @@ -716,10 +716,10 @@ (defn with-no-catches [body] "(All [a] (-> (Lux a) (Lux a)))" (fn [state] - (let [old-catching (->> state (get$ $host) (get$ $catching))] - (|case (body (update$ $host #(set$ $catching $Nil %) state)) + (let [old-catching (->> state (get$ $catching))] + (|case (body (set$ $catching $Nil state)) ($Right state* output) - (return* (update$ $host #(set$ $catching old-catching %) state*) output) + (return* (set$ $catching old-catching state*) output) ($Left msg) (fail* msg))))) @@ -750,6 +750,8 @@ 0 ;; scope-type-vars $Nil + ;; catching + $Nil ;; "lux;host" host-data] )) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index bb333df57..809c03022 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -232,8 +232,6 @@ (memory-class-loader store) ;; "lux;classes" store - ;; "lux;catching" - &/$Nil ;; "lux;module-states" (&/|table) ;; lux;type-env -- cgit v1.2.3 From 856948baa67c60059a4ffdc65c563d1dfa350363 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 1 Feb 2017 20:35:58 -0400 Subject: - Now wrapping macros to make sure all macros can be invoked, regardless of whether it's JVM code or any other kind of code. --- luxc/src/lux/analyser.clj | 7 ++++--- luxc/src/lux/analyser/jvm.clj | 2 +- luxc/src/lux/analyser/lux.clj | 4 ++-- luxc/src/lux/compiler/jvm.clj | 1 + 4 files changed, 8 insertions(+), 6 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 50edefac4..d895b1aaa 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -60,7 +60,8 @@ (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) [cursor token] ?token compile-def (aget compilers 0) - compile-program (aget compilers 1)] + compile-program (aget compilers 1) + macro-wrapper (aget compilers 2)] (|case token ;; Standard special forms (&/$BoolS ?value) @@ -171,7 +172,7 @@ ;; else (&/with-cursor cursor (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + (&&lux/analyse-apply analyse cursor exo-type macro-wrapper =fn parameters)))) (&/$NatS idx) (&/with-analysis-meta cursor exo-type @@ -184,7 +185,7 @@ _ (&/with-cursor cursor (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type =fn parameters)))) + (&&lux/analyse-apply analyse cursor exo-type macro-wrapper =fn parameters)))) _ (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj index 5ea64d41a..b82c634d6 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/jvm.clj @@ -1142,7 +1142,7 @@ ) (defn analyse-host [analyse exo-type compilers category proc ?values] - (|let [[_ _ compile-class compile-interface] compilers] + (|let [[_ _ _ compile-class compile-interface] compilers] (case category "lux" (case proc diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index 27f4ee11e..b990b738c 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -375,7 +375,7 @@ (&&/$apply =fn =args) ))))) -(defn analyse-apply [analyse cursor exo-type =fn ?args] +(defn analyse-apply [analyse cursor exo-type macro-wrapper =fn ?args] (|do [loader &/loader :let [[[=fn-type =fn-cursor] =fn-form] =fn]] (|case =fn-form @@ -384,7 +384,7 @@ (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) (|do [macro-expansion (fn [state] - (|case (-> ?value (.apply ?args) (.apply state)) + (|case ((macro-wrapper ?value) ?args state) (&/$Right state* output) (&/$Right (&/T [state* output])) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 809c03022..a5c5ee210 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -161,6 +161,7 @@ (let [compile-expression* (partial compile-expression nil)] (&/T [(partial &&lux/compile-def compile-expression) (partial &&lux/compile-program compile-expression*) + (fn [macro] (fn [args state] (-> macro (.apply args) (.apply state)))) (partial &&host/compile-jvm-class compile-expression*) &&host/compile-jvm-interface]))) -- cgit v1.2.3 From 88a6dee335155753674eccf245e6a041542604aa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 1 Feb 2017 20:42:03 -0400 Subject: - WIP: Code for compiling Lux to JavaScript. Can handle some complex expressions, like functions and pattern-matching. - Currently working on macros. --- luxc/src/lux/compiler.clj | 2 +- luxc/src/lux/compiler/js.clj | 182 +++++++ luxc/src/lux/compiler/js/base.clj | 135 ++++++ luxc/src/lux/compiler/js/lux.clj | 468 ++++++++++++++++++ luxc/src/lux/compiler/js/rt.clj | 994 ++++++++++++++++++++++++++++++++++++++ 5 files changed, 1780 insertions(+), 1 deletion(-) create mode 100644 luxc/src/lux/compiler/js.clj create mode 100644 luxc/src/lux/compiler/js/base.clj create mode 100644 luxc/src/lux/compiler/js/lux.clj create mode 100644 luxc/src/lux/compiler/js/rt.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj index fafb35818..0e78fa766 100644 --- a/luxc/src/lux/compiler.clj +++ b/luxc/src/lux/compiler.clj @@ -7,7 +7,7 @@ [io :as &&io] [parallel :as &¶llel] [jvm :as &&jvm] - ;; [js :as &&js] + [js :as &&js] ))) (defn init! [resources-dirs ^String target-dir] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj new file mode 100644 index 000000000..6334b1d9a --- /dev/null +++ b/luxc/src/lux/compiler/js.clj @@ -0,0 +1,182 @@ +(ns lux.compiler.js + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case]] + [type :as &type] + [reader :as &reader] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &optimizer]) + [lux.optimizer :as &o] + [lux.analyser.base :as &a] + [lux.analyser.module :as &a-module] + (lux.compiler [core :as &&core] + [io :as &&io] + [parallel :as &¶llel]) + (lux.compiler.js [base :as &&] + ;; [cache :as &&cache] + [lux :as &&lux] + [rt :as &&rt] + ;; [host :as &&host] + ) + ) + (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory + NashornScriptEngine + ScriptObjectMirror) + (jdk.nashorn.internal.runtime Undefined)) + ) + +;; [Resources] +(defn ^:private compile-expression [syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|case ?form + (&o/$bool ?value) + (&&lux/compile-bool ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$deg ?value) + (&&lux/compile-deg ?value) + + (&o/$real ?value) + (&&lux/compile-real ?value) + + (&o/$char ?value) + (&&lux/compile-char ?value) + + (&o/$text ?value) + (&&lux/compile-text ?value) + + (&o/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?elems) + + (&o/$var (&/$Local ?idx)) + (&&lux/compile-local compile-expression ?idx) + + ;; (&o/$captured ?scope ?captured-id ?source) + ;; (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + + (&o/$var (&/$Global ?module ?name)) + (&&lux/compile-global ?module ?name) + + (&o/$apply ?fn ?args) + (&&lux/compile-apply compile-expression ?fn ?args) + + ;; (&o/$loop _register-offset _inits _body) + ;; (&&lux/compile-loop compile-expression _register-offset _inits _body) + + ;; (&o/$iter _register-offset ?args) + ;; (&&lux/compile-iter compile-expression _register-offset ?args) + + (&o/$variant ?tag ?tail ?members) + (&&lux/compile-variant compile-expression ?tag ?tail ?members) + + (&o/$case ?value [?pm ?bodies]) + (&&lux/compile-case compile-expression ?value ?pm ?bodies) + + (&o/$let _value _register _body) + (&&lux/compile-let compile-expression _value _register _body) + + ;; (&o/$record-get _value _path) + ;; (&&lux/compile-record-get compile-expression _value _path) + + ;; (&o/$if _test _then _else) + ;; (&&lux/compile-if compile-expression _test _then _else) + + (&o/$function _register-offset ?arity ?scope ?env ?body) + (&&lux/compile-function compile-expression ?arity ?scope ?env ?body) + + (&o/$ann ?value-ex ?type-ex) + (compile-expression ?value-ex) + + ;; (&o/$proc [?proc-category ?proc-name] ?args special-args) + ;; (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args) + + _ + (assert false (prn-str 'JS=compile-expression| (&/adt->text syntax)))) + )) + +(defn init! + "(-> (List Text) Null)" + [resources-dirs ^String target-dir] + nil) + +(defn eval! [expr] + (&/with-eval + (|do [compiled-expr (compile-expression expr) + js-output (&&/run-js! compiled-expr)] + (return (&&/js-to-lux js-output))))) + +(def all-compilers + (&/T [(partial &&lux/compile-def compile-expression) + (partial &&lux/compile-program compile-expression) + (fn [^ScriptObjectMirror macro] + (fn [args state] + (let [output (.call macro nil (to-array [(&&/wrap-lux-obj args) + (&&/wrap-lux-obj state)]))] + (do (prn 'output output) + (assert false "Got macros?")))))])) + +(defn compile-module [source-dirs name] + (let [file-name (str name ".lux")] + (|do [file-content (&&io/read-file source-dirs file-name) + :let [file-hash (hash file-content) + ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) + compile-module!! (partial compile-module source-dirs)]] + ;; (&/|eitherL (&&cache/load name)) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) + (|do [;; _ (&&cache/delete name) + _ (&a-module/create-module name file-hash) + _ (&a-module/flag-active-module name) + _ (if (= "lux" name) + &&rt/compile-LuxRT + (return nil)) + ] + (fn [state] + (|case ((&/exhaust% compiler-step) + ;; (&/with-writer =class + ;; (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [_ (&a-module/flag-compiled-module name) + ;; _ (&&/save-class! &/module-class-name (.toByteArray =class)) + module-descriptor &&core/generate-module-descriptor + _ (&&core/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message))))))) + ) + )) + +(let [!err! *err*] + (defn compile-program [mode program-module resources-dir source-dirs target-dir] + (do (init! resources-dir target-dir) + (let [m-action (|do [;; _ (&&cache/pre-load-cache! source-dirs) + _ (compile-module source-dirs "lux")] + (compile-module source-dirs program-module))] + (|case (m-action (&/init-state mode (&&/js-host))) + (&/$Right ?state _) + (do (println "Compilation complete!") + ;; (&&cache/clean ?state) + ) + + (&/$Left ?message) + (binding [*out* !err!] + (do (println (str "Compilation failed:\n" ?message)) + ;; (flush) + ;; (System/exit 1) + ))))))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj new file mode 100644 index 000000000..d3746f01c --- /dev/null +++ b/luxc/src/lux/compiler/js/base.clj @@ -0,0 +1,135 @@ +(ns lux.compiler.js.base + (:refer-clojure :exclude [compile]) + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftuple |let |do return* return |case]] + [host :as &host]) + [lux.compiler.core :as &&] + ) + (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory + NashornScriptEngine + ScriptObjectMirror + JSObject) + (jdk.nashorn.internal.runtime Undefined) + (java.io File + BufferedOutputStream + FileOutputStream)) + ) + +(deftuple + ["interpreter" + "buffer"]) + +(defn js-host [] + (&/T [;; "interpreter" + (.getScriptEngine (new NashornScriptEngineFactory)) + ;; "buffer" + &/$None + ])) + +(defn run-js! [^String js-code] + (fn [compiler-state] + (|let [^NashornScriptEngine interpreter (->> compiler-state (&/get$ &/$host) (&/get$ $interpreter))] + (try (&/$Right (&/T [compiler-state + (.eval interpreter js-code)])) + (catch Exception ex + (&/$Left (str ex))))))) + +(def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) + +(defn ^:private _valueOf_ [value] + (reify JSObject + (isFunction [self] true) + (call [self this args] + value))) + +(defn ^:private _slice_ [wrap-lux-obj value] + (reify JSObject + (isFunction [self] true) + (call [self this args] + (prn '_slice_ (seq args)) + (let [slice (java.util.Arrays/copyOfRange value (aget args 0) (alength value))] + (wrap-lux-obj slice))))) + +(defn ^:private _toString_ [obj] + (reify JSObject + (isFunction [self] true) + (call [self this args] + (&/adt->text obj) + ;; (pr-str this) + ))) + +(defn wrap-lux-obj [obj] + (if (instance? lux-obj-class obj) + (reify JSObject + (isFunction [self] false) + (getSlot [self idx] + (wrap-lux-obj (aget obj idx))) + (getMember [self member] + (condp = member + ;; "valueOf" (_valueOf_ obj) + "toString" (_toString_ obj) + "length" (alength obj) + "slice" (_slice_ wrap-lux-obj obj) + ;; else + (assert false (str "member = " member))))) + obj)) + +(defn js-to-lux [js-object] + (cond (instance? java.lang.Integer js-object) + (long js-object) + + (or (nil? js-object) + (instance? java.lang.Boolean js-object) + (instance? java.lang.String js-object)) + js-object + + ;; (instance? Undefined js-object) + ;; (assert false "UNDEFINED") + + (instance? ScriptObjectMirror js-object) + (let [^ScriptObjectMirror js-object js-object] + (cond (.isArray js-object) + (let [array-vec (loop [num-keys (.size js-object) + idx 0 + array-vec []] + (if (< idx num-keys) + (let [idx-key (str idx)] + (if (.hasMember js-object idx-key) + (recur num-keys + (inc idx) + (conj array-vec (js-to-lux (.getMember js-object idx-key)))) + (recur (inc num-keys) + (inc idx) + (conj array-vec nil)))) + array-vec))] + (&/T array-vec)) + + (.isFunction js-object) + js-object + + :else + (assert false (str "Unknown kind of JS object: " js-object)))) + + :else + (assert false (str "Unknown kind of JS object: " (class js-object) " :: " js-object)))) + +(defn run-js!+ [^String js-code] + (|do [raw (run-js! js-code)] + (return (js-to-lux raw)))) + +(def ^String unit (pr-str &/unit-tag)) + +(defn save-js! [name ^String script] + (|do [_ (run-js! script) + eval? &/get-eval + module &/get-module-name + :let [_ (when (not eval?) + (let [^String module* (&host/->module-class module) + module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] + (do (.mkdirs (File. module-dir)) + (&&/write-file (str module-dir java.io.File/separator name ".js") (.getBytes script)))))]] + (return nil))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj new file mode 100644 index 000000000..fe45350b5 --- /dev/null +++ b/luxc/src/lux/compiler/js/lux.clj @@ -0,0 +1,468 @@ +(ns lux.compiler.js.lux + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [host :as &host] + [optimizer :as &o]) + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler.js [base :as &&] + [rt :as &&rt]) + )) + +;; [Utils] +(defn ^:private js-var-name [module name] + (str (string/replace module "/" "$") "$" (&host/def-name name))) + +(defn ^:private register-name [register] + (str "_" register)) + +;; [Exports] +(defn compile-bool [?value] + (return (str ?value))) + +(do-template [] + (defn [value] + (return (str value "|0"))) + + compile-nat + compile-int + compile-deg + ) + +(defn compile-real [value] + (return (str value))) + +(defn compile-char [value] + (return (str "\"" value "\""))) + +(defn compile-text [?value] + (return (pr-str ?value))) + +(defn compile-tuple [compile ?elems] + (|do [:let [num-elems (&/|length ?elems)]] + (|case num-elems + 0 + (return &&/unit) + + 1 + (compile (&/|head ?elems)) + + _ + (|do [=elems (&/map% compile ?elems)] + (return (str "[" (->> =elems (&/|interpose ",") (&/fold str "")) "]")))))) + +(defn compile-variant [compile tag tail? value] + (|do [value-expr (compile value)] + (return (str "[" tag + "," (if tail? "\"\"" "null") + "," value-expr + "]")))) + +(defn compile-local [compile register] + (return (register-name register))) + +;; (defn compile-captured [compile ?scope ?captured-id ?source] +;; (|do [:let [??scope (&/|reverse ?scope)] +;; ^MethodVisitor *writer* &/get-writer +;; :let [_ (doto *writer* +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitFieldInsn Opcodes/GETFIELD +;; (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) +;; (str &&/closure-prefix ?captured-id) +;; "Ljava/lang/Object;"))]] +;; (return nil))) + +(defn compile-global [module name] + (return (js-var-name module name))) + +(defn compile-apply [compile ?fn ?args] + (|do [=fn (compile ?fn) + =args (&/map% compile ?args)] + (return (str =fn "(" (->> =args (&/|interpose ",") (&/fold str "")) ")")))) + +;; (defn compile-loop [compile-expression register-offset inits body] +;; (|do [^MethodVisitor *writer* &/get-writer +;; :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) +;; inits)] +;; _ (&/map% (fn [idx+_init] +;; (|do [:let [[idx _init] idx+_init +;; idx+ (+ register-offset idx)] +;; _ (compile-expression nil _init) +;; :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] +;; (return nil))) +;; idxs+inits) +;; :let [$begin (new Label) +;; _ (.visitLabel *writer* $begin)]] +;; (compile-expression $begin body) +;; )) + +;; (defn compile-iter [compile $begin register-offset ?args] +;; (|do [^MethodVisitor *writer* &/get-writer +;; :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) +;; ?args)] +;; _ (&/map% (fn [idx+?arg] +;; (|do [:let [[idx ?arg] idx+?arg +;; idx+ (+ register-offset idx) +;; already-set? (|case ?arg +;; [_ (&o/$var (&/$Local l-idx))] +;; (= idx+ l-idx) + +;; _ +;; false)]] +;; (if already-set? +;; (return nil) +;; (compile ?arg)))) +;; idxs+args) +;; _ (&/map% (fn [idx+?arg] +;; (|do [:let [[idx ?arg] idx+?arg +;; idx+ (+ register-offset idx) +;; already-set? (|case ?arg +;; [_ (&o/$var (&/$Local l-idx))] +;; (= idx+ l-idx) + +;; _ +;; false)] +;; :let [_ (when (not already-set?) +;; (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] +;; (return nil))) +;; (&/|reverse idxs+args)) +;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] +;; (return nil))) + +(defn compile-let [compile _value _register _body] + (|do [=value (compile _value) + =body (compile _body)] + (return (str "(function() {" + "var " (register-name _register) " = " =value ";" + " return " =body + ";})()")))) + +;; (defn compile-record-get [compile _value _path] +;; (|do [^MethodVisitor *writer* &/get-writer +;; _ (compile _value) +;; :let [_ (&/|map (fn [step] +;; (|let [[idx tail?] step] +;; (doto *writer* +;; (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") +;; (.visitLdcInsn (int idx)) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" +;; (if tail? "product_getRight" "product_getLeft") +;; "([Ljava/lang/Object;I)Ljava/lang/Object;")))) +;; _path)]] +;; (return nil))) + +;; (defn compile-if [compile _test _then _else] +;; (|do [^MethodVisitor *writer* &/get-writer +;; _ (compile _test) +;; :let [$else (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; &&/unwrap-boolean +;; (.visitJumpInsn Opcodes/IFEQ $else))] +;; _ (compile _then) +;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] +;; :let [_ (.visitLabel *writer* $else)] +;; _ (compile _else) +;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) +;; _ (.visitLabel *writer* $end)]] +;; (return nil))) + +(def ^:private original "pm_stack_original") +(def ^:private stack "pm_stack") +(defn ^:private stack-push [value] + (str stack ".push(" value ");")) +(def ^:private stack-init (str stack " = " original ".slice();")) +(def ^:private stack-peek (str stack "[" stack ".length - 1]")) +(def ^:private stack-pop (str stack ".pop();")) +(def ^:private pm-error (.intern (pr-str (str (char 0) "PM-ERROR" (char 0))))) +(def ^:private pm-fail (str "throw " pm-error ";")) + +(defn ^:private compile-pm* [compile pm bodies] + "(-> Case-Pattern (List Analysis) (Lux JS))" + (|case pm + (&o/$ExecPM _body-idx) + (|case (&/|at _body-idx bodies) + (&/$Some body) + (|do [=body (compile body)] + (return (str "return " =body ";"))) + + (&/$None) + (assert false)) + + (&o/$PopPM) + (return stack-pop) + + (&o/$BindPM _register) + (return (str "var " (register-name _register) " = " stack-peek ";" + stack-pop)) + + (&o/$BoolPM _value) + (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + + (&o/$NatPM _value) + (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + + (&o/$IntPM _value) + (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + + (&o/$DegPM _value) + (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + + (&o/$RealPM _value) + (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + + (&o/$CharPM _value) + (return (str "if(" stack-peek "!== \"" _value "\") { " pm-fail " }")) + + (&o/$TextPM _value) + (return (str "if(" stack-peek "!== \"" _value "\") { " pm-fail " }")) + + (&o/$TuplePM _idx+) + (|let [[_idx is-tail?] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + getter (if is-tail? "product_getRight" "product_getLeft")] + (return (str (stack-push (str &&rt/LuxRT "." getter "(" stack-peek "," _idx ")"))))) + + (&o/$VariantPM _idx+) + (|let [[_idx is-last] (|case _idx+ + (&/$Left _idx) + (&/T [_idx false]) + + (&/$Right _idx) + (&/T [_idx true])) + temp-assignment (str "temp = " &&rt/LuxRT "." "sum_get(" stack-peek "," _idx "," (if is-last "\"\"" "null") ");")] + (return (str temp-assignment + (str "if(temp) {" + (stack-push "temp") + "}" + "else {" + pm-fail + "}")))) + + (&o/$SeqPM _left-pm _right-pm) + (|do [=left (compile-pm* compile _left-pm bodies) + =right (compile-pm* compile _right-pm bodies)] + (return (str =left =right))) + + (&o/$AltPM _left-pm _right-pm) + (|do [=left (compile-pm* compile _left-pm bodies) + =right (compile-pm* compile _right-pm bodies)] + (return (str "try {" =left "}" + "catch(ex) {" + "if(ex === " pm-error ") {" + stack-init + =right + "}" + "else {" + "throw ex;" + "}" + "}"))) + )) + +(defn ^:private compile-pm [compile pm bodies] + (|do [raw (compile-pm* compile pm bodies)] + (return (str "try {" raw "}" + "catch(ex) {" + "if(ex === " pm-error ") {" + "throw \"Invalid expression for pattern-matching.\";" + "}" + "else {" + "throw ex;" + "}" + "}")))) + +;; [Resources] +(defn compile-case [compile ?value ?pm ?bodies] + (|do [=value (compile ?value) + =pm (compile-pm compile ?pm ?bodies)] + (return (str "(function() {" + "\"use strict\";" + "var temp;" + "var " original " = [" =value "];" + "var " stack-init + =pm + "})()")))) + +(defn compile-function [compile arity ?scope ?env ?body] + (|do [:let [??scope (&/|reverse ?scope) + function-name (str (&host/->module-class (&/|head ??scope)) + "$" (&host/location (&/|tail ??scope))) + func-args (->> (&/|range* 0 (dec arity)) + (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) + (&/fold str ""))] + =body (compile ?body)] + (return (str "(function " function-name "() {" + "\"use strict\";" + "var num_args = arguments.length;" + "if(num_args == " arity ") {" + "var " (register-name 0) " = " function-name ";" + func-args + "return " =body ";" + "}" + "else if(num_args > " arity ") {" + "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" + ".apply(null, [].slice.call(arguments," arity "));" + "}" + ;; Less than arity + "else {" + "var curried = [].slice.call(arguments);" + "return function() { " + "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" + " };" + "}" + "})")))) + +(defn compile-def [compile ?name ?body def-meta] + (|do [module-name &/get-module-name + class-loader &/loader + :let [var-name (js-var-name module-name ?name)]] + (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) + (&/$Some (&/$IdentA [r-module r-name])) + (if (= 1 (&/|length def-meta)) + (|do [def-value (&&/run-js! var-name) + def-type (&a-module/def-type r-module r-name) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value))] + (return nil)) + (&/fail-with-loc (str "[Compilation Error] Aliases cannot contain meta-data: " module-name ";" ?name))) + + (&/$Some _) + (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") + + _ + (|do [=body (compile ?body) + :let [def-js (str "var " var-name " = " =body ";") + is-type? (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) + (&/$Some (&/$BoolA true)) + true + + _ + false) + def-type (&a/expr-type* ?body) + _ (&/|log! (str "def-js >>\n" + (string/replace def-js "" "^@")))] + _ (&&/run-js! def-js) + def-value (&&/run-js!+ var-name) + _ (&/without-repl-closure + (&a-module/define module-name ?name def-type def-meta def-value)) + _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) + [true (&/$Some (&/$ListA tags*))] + (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + (&/$TextA tag) + (return tag) + + _ + (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) + tags*) + _ (&a-module/declare-tags module-name tags was-exported? def-value)] + (return nil)) + + [false (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Can't define tags for non-type.") + + [true (&/$Some _)] + (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") + + [_ (&/$None)] + (return nil)) + :let [_ (println 'DEF (str module-name ";" ?name))]] + (return nil)) + )) + ) + +(defn compile-program [compile ?body] + (assert false "compile-program") + ;; (|do [module-name &/get-module-name + ;; ^ClassWriter *writer* &/get-writer] + ;; (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) + ;; (.visitCode)) + ;; (|do [^MethodVisitor main-writer &/get-writer + ;; :let [$loop (new Label) + ;; $end (new Label) + ;; _ (doto main-writer + ;; ;; Tail: Begin + ;; (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I + ;; (.visitInsn Opcodes/ACONST_NULL) ;; I? + ;; (.visitLdcInsn &/unit-tag) ;; I?U + ;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V + ;; ;; Tail: End + ;; ;; Size: Begin + ;; (.visitVarInsn Opcodes/ALOAD 0) ;; VA + ;; (.visitInsn Opcodes/ARRAYLENGTH) ;; VI + ;; ;; Size: End + ;; ;; Loop: Begin + ;; (.visitLabel $loop) + ;; (.visitLdcInsn (int 1)) ;; VII + ;; (.visitInsn Opcodes/ISUB) ;; VI + ;; (.visitInsn Opcodes/DUP) ;; VII + ;; (.visitJumpInsn Opcodes/IFLT $end) ;; VI + ;; ;; Head: Begin + ;; (.visitInsn Opcodes/DUP) ;; VII + ;; (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA + ;; (.visitInsn Opcodes/SWAP) ;; VIAI + ;; (.visitInsn Opcodes/AALOAD) ;; VIO + ;; (.visitInsn Opcodes/SWAP) ;; VOI + ;; (.visitInsn Opcodes/DUP_X2) ;; IVOI + ;; (.visitInsn Opcodes/POP) ;; IVO + ;; ;; Head: End + ;; ;; Tuple: Begin + ;; (.visitLdcInsn (int 2)) ;; IVOS + ;; (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 + ;; (.visitInsn Opcodes/DUP_X1) ;; IV2O2 + ;; (.visitInsn Opcodes/SWAP) ;; IV22O + ;; (.visitLdcInsn (int 0)) ;; IV22OI + ;; (.visitInsn Opcodes/SWAP) ;; IV22IO + ;; (.visitInsn Opcodes/AASTORE) ;; IV2 + ;; (.visitInsn Opcodes/DUP_X1) ;; I2V2 + ;; (.visitInsn Opcodes/SWAP) ;; I22V + ;; (.visitLdcInsn (int 1)) ;; I22VI + ;; (.visitInsn Opcodes/SWAP) ;; I22IV + ;; (.visitInsn Opcodes/AASTORE) ;; I2 + ;; ;; Tuple: End + ;; ;; Cons: Begin + ;; (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I + ;; (.visitLdcInsn "") ;; I2I? + ;; (.visitInsn Opcodes/DUP2_X1) ;; II?2I? + ;; (.visitInsn Opcodes/POP2) ;; II?2 + ;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV + ;; ;; Cons: End + ;; (.visitInsn Opcodes/SWAP) ;; VI + ;; (.visitJumpInsn Opcodes/GOTO $loop) + ;; ;; Loop: End + ;; (.visitLabel $end) ;; VI + ;; (.visitInsn Opcodes/POP) ;; V + ;; (.visitVarInsn Opcodes/ASTORE (int 0)) ;; + ;; ) + ;; ] + ;; _ (compile ?body) + ;; :let [_ (doto main-writer + ;; (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + ;; (.visitInsn Opcodes/ACONST_NULL) + ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + ;; :let [_ (doto main-writer + ;; (.visitInsn Opcodes/POP) + ;; (.visitInsn Opcodes/RETURN) + ;; (.visitMaxs 0 0) + ;; (.visitEnd))]] + ;; (return nil)))) + ) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj new file mode 100644 index 000000000..c54c9debf --- /dev/null +++ b/luxc/src/lux/compiler/js/rt.clj @@ -0,0 +1,994 @@ +(ns lux.compiler.js.rt + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.analyser.base :as &a] + [lux.compiler.js.base :as &&])) + +;; (defn ^:private low-4b [^MethodVisitor =method] +;; (doto =method +;; ;; Assume there is a long at the top of the stack... +;; ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. +;; (.visitLdcInsn (int -1)) +;; (.visitInsn Opcodes/I2L) +;; ;; Then do a bitwise and. +;; (.visitInsn Opcodes/LAND) +;; )) + +;; (defn ^:private high-4b [^MethodVisitor =method] +;; (doto =method +;; ;; Assume there is a long at the top of the stack... +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LUSHR) +;; )) + +;; (defn ^:private swap2 [^MethodVisitor =method] +;; (doto =method +;; ;; X2, Y2 +;; (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 +;; (.visitInsn Opcodes/POP2) ;; Y2, X2 +;; )) + +;; (defn ^:private swap2x1 [^MethodVisitor =method] +;; (doto =method +;; ;; X1, Y2 +;; (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 +;; (.visitInsn Opcodes/POP2) ;; Y2, X1 +;; )) + +;; (defn ^:private bit-set-64? [^MethodVisitor =method] +;; (doto =method +;; ;; L, I +;; (.visitLdcInsn (long 1)) ;; L, I, L +;; (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L +;; (.visitInsn Opcodes/POP2) ;; L, L, I +;; (.visitInsn Opcodes/LSHL) ;; L, L +;; (.visitInsn Opcodes/LAND) ;; L +;; (.visitLdcInsn (long 0)) ;; L, L +;; (.visitInsn Opcodes/LCMP) ;; I +;; )) + +;; (defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] +;; (|let [deg-bits 64 +;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) +;; ;; Based on: http://stackoverflow.com/a/31629280/6823464 +;; (.visitCode) +;; ;; Bottom part +;; (.visitVarInsn Opcodes/LLOAD 0) low-4b +;; (.visitVarInsn Opcodes/LLOAD 2) low-4b +;; (.visitInsn Opcodes/LMUL) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LUSHR) +;; ;; Middle part +;; (.visitVarInsn Opcodes/LLOAD 0) high-4b +;; (.visitVarInsn Opcodes/LLOAD 2) low-4b +;; (.visitInsn Opcodes/LMUL) +;; (.visitVarInsn Opcodes/LLOAD 0) low-4b +;; (.visitVarInsn Opcodes/LLOAD 2) high-4b +;; (.visitInsn Opcodes/LMUL) +;; (.visitInsn Opcodes/LADD) +;; ;; Join middle and bottom +;; (.visitInsn Opcodes/LADD) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LUSHR) +;; ;; Top part +;; (.visitVarInsn Opcodes/LLOAD 0) high-4b +;; (.visitVarInsn Opcodes/LLOAD 2) high-4b +;; (.visitInsn Opcodes/LMUL) +;; ;; Join top with rest +;; (.visitInsn Opcodes/LADD) +;; ;; Return +;; (.visitInsn Opcodes/LRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)) +;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) +;; (.visitCode) +;; ;; Based on: http://stackoverflow.com/a/8510587/6823464 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/LLOAD 2) high-4b +;; (.visitInsn Opcodes/LDIV) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LSHL) +;; (.visitInsn Opcodes/LRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)) +;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) +;; (.visitCode) +;; ;; Translate high bytes +;; (.visitVarInsn Opcodes/LLOAD 0) high-4b +;; (.visitInsn Opcodes/L2D) +;; (.visitLdcInsn (double (Math/pow 2 32))) +;; (.visitInsn Opcodes/DDIV) +;; ;; Translate low bytes +;; (.visitVarInsn Opcodes/LLOAD 0) low-4b +;; (.visitInsn Opcodes/L2D) +;; (.visitLdcInsn (double (Math/pow 2 32))) +;; (.visitInsn Opcodes/DDIV) +;; (.visitLdcInsn (double (Math/pow 2 32))) +;; (.visitInsn Opcodes/DDIV) +;; ;; Combine and return +;; (.visitInsn Opcodes/DADD) +;; (.visitInsn Opcodes/DRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)) +;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) +;; (.visitCode) +;; ;; Drop any excess +;; (.visitVarInsn Opcodes/DLOAD 0) +;; (.visitLdcInsn (double 1.0)) +;; (.visitInsn Opcodes/DREM) +;; ;; Shift upper half, but retain remaining decimals +;; (.visitLdcInsn (double (Math/pow 2 32))) +;; (.visitInsn Opcodes/DMUL) +;; ;; Make a copy, so the lower half can be extracted +;; (.visitInsn Opcodes/DUP2) +;; ;; Get that lower half +;; (.visitLdcInsn (double 1.0)) +;; (.visitInsn Opcodes/DREM) +;; (.visitLdcInsn (double (Math/pow 2 32))) +;; (.visitInsn Opcodes/DMUL) +;; ;; Turn it into a deg +;; (.visitInsn Opcodes/D2L) +;; ;; Turn the upper half into deg too +;; swap2 +;; (.visitInsn Opcodes/D2L) +;; ;; Combine both pieces +;; (.visitInsn Opcodes/LADD) +;; ;; FINISH +;; (.visitInsn Opcodes/LRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) +;; (.visitCode) +;; (.visitLdcInsn (int 0)) ;; {carry} +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 0) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; {carry} +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 0) +;; (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} +;; (.visitLdcInsn (int 5)) +;; (.visitInsn Opcodes/IMUL) +;; (.visitInsn Opcodes/IADD) ;; {next-raw-digit} +;; (.visitInsn Opcodes/DUP) +;; (.visitLdcInsn (int 10)) +;; (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 0) +;; swap2x1 +;; (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} +;; (.visitLdcInsn (int 10)) +;; (.visitInsn Opcodes/IDIV) ;; {next-carry} +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 0) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 0) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) +;; (.visitCode) +;; ;; Initialize digits array. +;; (.visitLdcInsn (int deg-bits)) +;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} +;; (.visitInsn Opcodes/DUP) +;; (.visitVarInsn Opcodes/ILOAD 0) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 +;; (.visitVarInsn Opcodes/ASTORE 1) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitVarInsn Opcodes/ILOAD 0) ;; {times} +;; (.visitLabel $loop-start) +;; (.visitInsn Opcodes/DUP) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; ;; {times} +;; (.visitVarInsn Opcodes/ILOAD 0) +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} +;; (.visitVarInsn Opcodes/ASTORE 1) ;; {times} +;; ;; Decrement index +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; ;; {times-1} +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) +;; (.visitCode) +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index +;; (.visitLdcInsn (int deg-bits)) +;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) +;; (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits +;; (.visitLdcInsn (int 0)) ;; {carry} +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; {carry} +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; ;; {carry} +;; (.visitVarInsn Opcodes/ALOAD 3) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; {carry} +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/BALOAD) ;; {carry, dL} +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} +;; (.visitInsn Opcodes/IADD) +;; (.visitInsn Opcodes/IADD) ;; {raw-next-digit} +;; (.visitInsn Opcodes/DUP) +;; (.visitLdcInsn (int 10)) +;; (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} +;; (.visitVarInsn Opcodes/ALOAD 3) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; swap2x1 +;; (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} +;; (.visitLdcInsn (int 10)) +;; (.visitInsn Opcodes/IDIV) ;; {next-carry} +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 2) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) +;; (.visitCode) +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index +;; (.visitLdcInsn "") ;; {text} +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitInsn Opcodes/BALOAD) ;; {text, digit} +;; (.visitLdcInsn (int 10)) ;; {text, digit, radix} +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} +;; (.visitInsn Opcodes/SWAP) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 1) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label) +;; $not-set (new Label) +;; $next-iteration (new Label) +;; $normal-path (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) +;; (.visitCode) +;; ;; A quick corner-case to handle. +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFNE $normal-path) +;; (.visitLdcInsn ".0") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitLabel $normal-path) +;; ;; Normal case +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index +;; (.visitLdcInsn (int deg-bits)) +;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) +;; (.visitVarInsn Opcodes/ASTORE 3) ;; digits +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; ;; Prepare text to return. +;; (.visitVarInsn Opcodes/ALOAD 3) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") +;; (.visitLdcInsn ".") +;; (.visitInsn Opcodes/SWAP) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") +;; ;; Trim unnecessary 0s at the end... +;; (.visitLdcInsn "0*$") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") +;; (.visitLdcInsn (int 0)) +;; (.visitInsn Opcodes/AALOAD) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; bit-set-64? +;; (.visitJumpInsn Opcodes/IFEQ $next-iteration) +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/ISUB) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") +;; (.visitVarInsn Opcodes/ALOAD 3) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") +;; (.visitVarInsn Opcodes/ASTORE 3) +;; (.visitJumpInsn Opcodes/GOTO $next-iteration) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $next-iteration) +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 2) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label) +;; $not-set (new Label) +;; $next-iteration (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) +;; (.visitCode) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index +;; (.visitLdcInsn (int deg-bits)) +;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) +;; (.visitVarInsn Opcodes/ASTORE 2) ;; digits +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 2) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/IADD) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") +;; ;; Set digit +;; (.visitVarInsn Opcodes/ALOAD 2) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; swap2x1 +;; (.visitInsn Opcodes/BASTORE) +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 1) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label) +;; $is-less-than (new Label) +;; $is-equal (new Label)] +;; ;; [B0 <= [B1 +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) +;; (.visitCode) +;; (.visitLdcInsn (int 0)) +;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int deg-bits)) +;; (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) +;; (.visitLdcInsn false) +;; (.visitInsn Opcodes/IRETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/BALOAD) ;; {D0} +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/BALOAD) ;; {D0, D1} +;; (.visitInsn Opcodes/DUP2) +;; (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) +;; (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) +;; ;; Is greater than... +;; (.visitLdcInsn false) +;; (.visitInsn Opcodes/IRETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $is-less-than) +;; (.visitInsn Opcodes/POP2) +;; (.visitLdcInsn true) +;; (.visitInsn Opcodes/IRETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $is-equal) +;; ;; Increment index +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/IADD) +;; (.visitVarInsn Opcodes/ISTORE 2) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label) +;; $simple-sub (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) +;; (.visitCode) +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} +;; (.visitInsn Opcodes/BALOAD) +;; (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} +;; (.visitInsn Opcodes/DUP2) +;; (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;; Since $0 < $1 +;; (.visitInsn Opcodes/SWAP) +;; (.visitInsn Opcodes/ISUB) ;; $1 - $0 +;; (.visitLdcInsn (byte 10)) +;; (.visitInsn Opcodes/SWAP) +;; (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; swap2x1 +;; (.visitInsn Opcodes/BASTORE) +;; ;; Prepare to iterate... +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 2) +;; ;; Subtract 1 from next digit +;; (.visitLdcInsn (int 1)) +;; (.visitVarInsn Opcodes/ISTORE 1) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $simple-sub) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; swap2x1 +;; (.visitInsn Opcodes/BASTORE) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitInsn Opcodes/ARETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$loop-start (new Label) +;; $do-a-round (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) +;; (.visitCode) +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitJumpInsn Opcodes/IFGE $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} +;; (.visitVarInsn Opcodes/ALOAD 1) +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} +;; (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") +;; (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits +;; ;; Decrement index +;; (.visitVarInsn Opcodes/ILOAD 2) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitVarInsn Opcodes/ISTORE 2) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; _ (let [$from (new Label) +;; $to (new Label) +;; $handler (new Label) +;; $loop-start (new Label) +;; $do-a-round (new Label) +;; $skip-power (new Label) +;; $iterate (new Label) +;; $bad-format (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) +;; (.visitCode) +;; ;; Check prefix +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitLdcInsn ".") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") +;; (.visitJumpInsn Opcodes/IFEQ $bad-format) +;; ;; Check if size is valid +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . +;; (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) +;; ;; Initialization +;; (.visitTryCatchBlock $from $to $handler "java/lang/Exception") +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitLdcInsn (int 1)) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") +;; (.visitLabel $from) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") +;; (.visitLabel $to) +;; (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... +;; (.visitLdcInsn (int 0)) +;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index +;; (.visitLdcInsn (long 0)) +;; (.visitVarInsn Opcodes/LSTORE 2) ;; Output +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $loop-start) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int deg-bits)) +;; (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; &&/wrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $do-a-round) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") +;; (.visitInsn Opcodes/DUP2) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") +;; (.visitJumpInsn Opcodes/IFNE $skip-power) +;; ;; Subtract power +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") +;; (.visitVarInsn Opcodes/ASTORE 0) +;; ;; Set bit on output +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitLdcInsn (long 1)) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int (dec deg-bits))) +;; (.visitInsn Opcodes/SWAP) +;; (.visitInsn Opcodes/ISUB) +;; (.visitInsn Opcodes/LSHL) +;; (.visitInsn Opcodes/LOR) +;; (.visitVarInsn Opcodes/LSTORE 2) +;; (.visitJumpInsn Opcodes/GOTO $iterate) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $skip-power) +;; (.visitInsn Opcodes/POP2) +;; ;; (.visitJumpInsn Opcodes/GOTO $iterate) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $iterate) +;; (.visitVarInsn Opcodes/ILOAD 1) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/IADD) +;; (.visitVarInsn Opcodes/ISTORE 1) +;; ;; Iterate +;; (.visitJumpInsn Opcodes/GOTO $loop-start) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $handler) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitLabel $bad-format) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)))] +;; nil)) + +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] +;; (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] +;; (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 +;; _ (let [$from (new Label) +;; $to (new Label) +;; $handler (new Label) + +;; $good-start (new Label) +;; $short-enough (new Label) +;; $bad-digit (new Label) +;; $out-of-bounds (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) +;; (.visitCode) +;; (.visitTryCatchBlock $from $to $handler "java/lang/Exception") +;; (.visitLabel $from) +;; ;; Remove the + at the beginning... +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitLdcInsn (int 0)) +;; (.visitLdcInsn (int 1)) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") +;; (.visitLdcInsn "+") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") +;; (.visitJumpInsn Opcodes/IFNE $good-start) +;; ;; Doesn't start with + +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; Starts with + +;; (.visitLabel $good-start) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitLdcInsn (int 1)) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") +;; (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... +;; ;; Begin parsing processs +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitLdcInsn (int 18)) +;; (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) +;; ;; Too long +;; ;; Get prefix... +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitLdcInsn (int 0)) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") +;; (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... +;; ;; Get last digit... +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/ISUB) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") +;; (.visitLdcInsn (int 10)) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") +;; ;; Test last digit... +;; (.visitInsn Opcodes/DUP) +;; (.visitJumpInsn Opcodes/IFLT $bad-digit) +;; ;; Good digit... +;; ;; Stack: prefix::L, prefix::L, last-digit::I +;; (.visitInsn Opcodes/I2L) +;; ;; Build the result... +;; swap2 +;; (.visitLdcInsn (long 10)) +;; (.visitInsn Opcodes/LMUL) +;; (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L +;; (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L +;; swap2 ;; Stack: result::L, result::L, prefix::L +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitJumpInsn Opcodes/IFLT $out-of-bounds) +;; ;; Within bounds +;; ;; Stack: result::L +;; &&/wrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; Out of bounds +;; (.visitLabel $out-of-bounds) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; Bad digit... +;; (.visitLabel $bad-digit) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; 18 chars or less +;; (.visitLabel $short-enough) +;; (.visitVarInsn Opcodes/ALOAD 0) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") +;; &&/wrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitLabel $to) +;; (.visitLabel $handler) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 +;; _ (let [$too-big (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) +;; (.visitCode) +;; (.visitLdcInsn "+") +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFLT $too-big) +;; ;; then +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; else +;; (.visitLabel $too-big) +;; ;; Set up parts of the number string... +;; ;; First digits +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (int 1)) +;; (.visitInsn Opcodes/LUSHR) +;; (.visitLdcInsn (long 5)) +;; (.visitInsn Opcodes/LDIV) ;; quot +;; ;; Last digit +;; (.visitInsn Opcodes/DUP2) +;; (.visitLdcInsn (long 10)) +;; (.visitInsn Opcodes/LMUL) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; swap2 +;; (.visitInsn Opcodes/LSUB) ;; quot, rem +;; ;; Conversion to string... +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* +;; (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* +;; (.visitInsn Opcodes/POP) ;; rem*, quot +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* +;; (.visitInsn Opcodes/SWAP) ;; quot*, rem* +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 +;; _ (let [$simple-case (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) +;; (.visitCode) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFGE $simple-case) +;; ;; else +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LUSHR) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") +;; (.visitLdcInsn (int 32)) +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LSHL) +;; (.visitLdcInsn (int 32)) +;; (.visitInsn Opcodes/LUSHR) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") +;; (.visitInsn Opcodes/ARETURN) +;; ;; then +;; (.visitLabel $simple-case) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") +;; (.visitInsn Opcodes/ARETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 +;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) +;; (.visitCode) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") +;; (.visitInsn Opcodes/LADD) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") +;; (.visitInsn Opcodes/LADD) +;; (.visitInsn Opcodes/LCMP) +;; (.visitInsn Opcodes/IRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd)) +;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 +;; _ (let [$case-1 (new Label) +;; $0 (new Label) +;; $case-2 (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) +;; (.visitCode) +;; ;; Test #1 +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFLT $case-1) +;; ;; Test #2 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFGT $case-2) +;; ;; Case #3 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") +;; (.visitInsn Opcodes/LRETURN) +;; ;; Case #2 +;; (.visitLabel $case-2) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitInsn Opcodes/LDIV) +;; (.visitInsn Opcodes/LRETURN) +;; ;; Case #1 +;; (.visitLabel $case-1) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitJumpInsn Opcodes/IFLT $0) +;; ;; 1 +;; (.visitLdcInsn (long 1)) +;; (.visitInsn Opcodes/LRETURN) +;; ;; 0 +;; (.visitLabel $0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LRETURN) +;; (.visitMaxs 0 0) +;; (.visitEnd))) +;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 +;; _ (let [$test-2 (new Label) +;; $case-2 (new Label)] +;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) +;; (.visitCode) +;; ;; Test #1 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFLE $test-2) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitLdcInsn (long 0)) +;; (.visitInsn Opcodes/LCMP) +;; (.visitJumpInsn Opcodes/IFLE $test-2) +;; ;; Case #1 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitInsn Opcodes/LREM) +;; (.visitInsn Opcodes/LRETURN) +;; ;; Test #2 +;; (.visitLabel $test-2) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitJumpInsn Opcodes/IFLT $case-2) +;; ;; Case #3 +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") +;; (.visitVarInsn Opcodes/LLOAD 2) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") +;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") +;; (.visitInsn Opcodes/LRETURN) +;; ;; Case #2 +;; (.visitLabel $case-2) +;; (.visitVarInsn Opcodes/LLOAD 0) +;; (.visitInsn Opcodes/LRETURN) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (.visitMaxs 0 0) +;; (.visitEnd)))] +;; nil))) + +(def ^:private adt-methods + {:product_getLeft (str "(function product_getLeft(product,index) {" + "var index_min_length = (index+1);" + "if(product.length > index_min_length) {" + ;; No need for recursion + "return product[index];" + "}" + "else {" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" + "}" + "})") + :product_getRight (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + :sum_get (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; Not match. + "else { return null; }" + "}" + ;; Not match. + "else { return null; }" + "})")}) + +(def LuxRT "LuxRT") + +(def compile-LuxRT + (|do [_ (return nil) + :let [rt-object (str "{" (->> adt-methods + (map (fn [[key val]] + (str (name key) ":" val))) + (interpose ",") + (reduce str "")) + "}")]] + (&&/save-js! LuxRT + (str "var " LuxRT " = " rt-object ";")))) -- cgit v1.2.3 From 8cd810a5df994d9bcef8d34605c1ac98900211e6 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 2 Feb 2017 19:18:26 -0400 Subject: - Improved conversions to/from JS. - Improved macro calls. - Improved pattern-matching. --- luxc/src/lux/analyser.clj | 6 ++--- luxc/src/lux/analyser/lux.clj | 21 +++++---------- luxc/src/lux/compiler/js.clj | 11 +++----- luxc/src/lux/compiler/js/base.clj | 43 +++++++++++++++++++------------ luxc/src/lux/compiler/js/lux.clj | 54 +++++++++++++++++++++------------------ luxc/src/lux/compiler/js/rt.clj | 7 ++--- luxc/src/lux/compiler/jvm.clj | 2 +- 7 files changed, 74 insertions(+), 70 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index d895b1aaa..b611c1f80 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -61,7 +61,7 @@ [cursor token] ?token compile-def (aget compilers 0) compile-program (aget compilers 1) - macro-wrapper (aget compilers 2)] + macro-caller (aget compilers 2)] (|case token ;; Standard special forms (&/$BoolS ?value) @@ -172,7 +172,7 @@ ;; else (&/with-cursor cursor (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type macro-wrapper =fn parameters)))) + (&&lux/analyse-apply analyse cursor exo-type macro-caller =fn parameters)))) (&/$NatS idx) (&/with-analysis-meta cursor exo-type @@ -185,7 +185,7 @@ _ (&/with-cursor cursor (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse cursor exo-type macro-wrapper =fn parameters)))) + (&&lux/analyse-apply analyse cursor exo-type macro-caller =fn parameters)))) _ (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index b990b738c..af7f0f3f9 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -375,7 +375,7 @@ (&&/$apply =fn =args) ))))) -(defn analyse-apply [analyse cursor exo-type macro-wrapper =fn ?args] +(defn analyse-apply [analyse cursor exo-type macro-caller =fn ?args] (|do [loader &/loader :let [[[=fn-type =fn-cursor] =fn-form] =fn]] (|case =fn-form @@ -384,25 +384,18 @@ (|case (&&meta/meta-get &&meta/macro?-tag ?meta) (&/$Some _) (|do [macro-expansion (fn [state] - (|case ((macro-wrapper ?value) ?args state) + (|case (macro-caller ?value ?args state) (&/$Right state* output) (&/$Right (&/T [state* output])) (&/$Left error) ((&/fail-with-loc error) state))) - module-name &/get-module-name + ;; module-name &/get-module-name ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "actor:" r-name) - ;; ;; (= "|Codec@Json|" r-name) - ;; ;; (= "|Codec@Json//encode|" r-name) - ;; ;; (= "|Codec@Json//decode|" r-name) - ;; ;; (= "derived:" r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name) module-name))) - ;; ] + ;; _ (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 6334b1d9a..8901bc154 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -102,7 +102,7 @@ ;; (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args) _ - (assert false (prn-str 'JS=compile-expression| (&/adt->text syntax)))) + (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) )) (defn init! @@ -119,12 +119,9 @@ (def all-compilers (&/T [(partial &&lux/compile-def compile-expression) (partial &&lux/compile-program compile-expression) - (fn [^ScriptObjectMirror macro] - (fn [args state] - (let [output (.call macro nil (to-array [(&&/wrap-lux-obj args) - (&&/wrap-lux-obj state)]))] - (do (prn 'output output) - (assert false "Got macros?")))))])) + (fn [^ScriptObjectMirror macro args state] + (&&/js-to-lux (.call macro nil (to-array [(&&/wrap-lux-obj args) + (&&/wrap-lux-obj state)]))))])) (defn compile-module [source-dirs name] (let [file-name (str name ".lux")] diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index d3746f01c..f89bbb9a2 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -50,7 +50,6 @@ (reify JSObject (isFunction [self] true) (call [self this args] - (prn '_slice_ (seq args)) (let [slice (java.util.Arrays/copyOfRange value (aget args 0) (alength value))] (wrap-lux-obj slice))))) @@ -62,31 +61,41 @@ ;; (pr-str this) ))) +(deftype LuxJsObject [obj] + JSObject + (isFunction [self] false) + (getSlot [self idx] + (let [value (aget obj idx)] + (if (instance? lux-obj-class value) + (new LuxJsObject value) + value))) + (getMember [self member] + (condp = member + ;; "valueOf" (_valueOf_ obj) + "toString" (_toString_ obj) + "length" (alength obj) + "slice" (let [wrap-lux-obj #(if (instance? lux-obj-class %) + (new LuxJsObject %) + %)] + (_slice_ wrap-lux-obj obj)) + ;; else + (assert false (str "wrap-lux-obj#getMember = " member))))) + (defn wrap-lux-obj [obj] (if (instance? lux-obj-class obj) - (reify JSObject - (isFunction [self] false) - (getSlot [self idx] - (wrap-lux-obj (aget obj idx))) - (getMember [self member] - (condp = member - ;; "valueOf" (_valueOf_ obj) - "toString" (_toString_ obj) - "length" (alength obj) - "slice" (_slice_ wrap-lux-obj obj) - ;; else - (assert false (str "member = " member))))) + (new LuxJsObject obj) obj)) (defn js-to-lux [js-object] - (cond (instance? java.lang.Integer js-object) - (long js-object) - - (or (nil? js-object) + (cond (or (nil? js-object) (instance? java.lang.Boolean js-object) + (instance? java.lang.Integer js-object) (instance? java.lang.String js-object)) js-object + (instance? LuxJsObject js-object) + (.-obj ^LuxJsObject js-object) + ;; (instance? Undefined js-object) ;; (assert false "UNDEFINED") diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index fe45350b5..3324a83c7 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -176,13 +176,14 @@ ;; _ (.visitLabel *writer* $end)]] ;; (return nil))) -(def ^:private original "pm_stack_original") -(def ^:private stack "pm_stack") -(defn ^:private stack-push [value] - (str stack ".push(" value ");")) -(def ^:private stack-init (str stack " = " original ".slice();")) -(def ^:private stack-peek (str stack "[" stack ".length - 1]")) -(def ^:private stack-pop (str stack ".pop();")) +(def ^:private savepoint "pm_cursor_savepoint") +(def ^:private cursor "pm_cursor") +(defn ^:private cursor-push [value] + (str cursor ".push(" value ");")) +(def ^:private cursor-save (str savepoint ".push(" cursor ".slice());")) +(def ^:private cursor-restore (str cursor " = " savepoint ".pop();")) +(def ^:private cursor-peek (str cursor "[" cursor ".length - 1]")) +(def ^:private cursor-pop (str cursor ".pop();")) (def ^:private pm-error (.intern (pr-str (str (char 0) "PM-ERROR" (char 0))))) (def ^:private pm-fail (str "throw " pm-error ";")) @@ -199,32 +200,32 @@ (assert false)) (&o/$PopPM) - (return stack-pop) + (return cursor-pop) (&o/$BindPM _register) - (return (str "var " (register-name _register) " = " stack-peek ";" - stack-pop)) + (return (str "var " (register-name _register) " = " cursor-peek ";" + cursor-pop)) (&o/$BoolPM _value) - (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$NatPM _value) - (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$IntPM _value) - (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$DegPM _value) - (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$RealPM _value) - (return (str "if(" stack-peek "!== " _value ") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$CharPM _value) - (return (str "if(" stack-peek "!== \"" _value "\") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " (pr-str (str _value)) ") { " pm-fail " }")) (&o/$TextPM _value) - (return (str "if(" stack-peek "!== \"" _value "\") { " pm-fail " }")) + (return (str "if(" cursor-peek " !== " (pr-str _value) ") { " pm-fail " }")) (&o/$TuplePM _idx+) (|let [[_idx is-tail?] (|case _idx+ @@ -234,7 +235,7 @@ (&/$Right _idx) (&/T [_idx true])) getter (if is-tail? "product_getRight" "product_getLeft")] - (return (str (stack-push (str &&rt/LuxRT "." getter "(" stack-peek "," _idx ")"))))) + (return (str (cursor-push (str &&rt/LuxRT "." getter "(" cursor-peek "," _idx ")"))))) (&o/$VariantPM _idx+) (|let [[_idx is-last] (|case _idx+ @@ -243,10 +244,10 @@ (&/$Right _idx) (&/T [_idx true])) - temp-assignment (str "temp = " &&rt/LuxRT "." "sum_get(" stack-peek "," _idx "," (if is-last "\"\"" "null") ");")] + temp-assignment (str "temp = " &&rt/LuxRT "." "sum_get(" cursor-peek "," _idx "," (if is-last "\"\"" "null") ");")] (return (str temp-assignment - (str "if(temp) {" - (stack-push "temp") + (str "if(temp !== null) {" + (cursor-push "temp") "}" "else {" pm-fail @@ -260,10 +261,13 @@ (&o/$AltPM _left-pm _right-pm) (|do [=left (compile-pm* compile _left-pm bodies) =right (compile-pm* compile _right-pm bodies)] - (return (str "try {" =left "}" + (return (str "try {" + cursor-save + =left + "}" "catch(ex) {" "if(ex === " pm-error ") {" - stack-init + cursor-restore =right "}" "else {" @@ -291,8 +295,8 @@ (return (str "(function() {" "\"use strict\";" "var temp;" - "var " original " = [" =value "];" - "var " stack-init + "var " cursor " = [" =value "];" + "var " savepoint " = [];" =pm "})()")))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index c54c9debf..3c9186a1e 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -973,12 +973,13 @@ ;; Must recurse. "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" "}" - ;; Not match. + ;; No match. "else { return null; }" "}" - ;; Not match. + ;; No match. "else { return null; }" - "})")}) + "})") + }) (def LuxRT "LuxRT") diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index a5c5ee210..5dac1fbbc 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -161,7 +161,7 @@ (let [compile-expression* (partial compile-expression nil)] (&/T [(partial &&lux/compile-def compile-expression) (partial &&lux/compile-program compile-expression*) - (fn [macro] (fn [args state] (-> macro (.apply args) (.apply state)))) + (fn [macro args state] (-> macro (.apply args) (.apply state))) (partial &&host/compile-jvm-class compile-expression*) &&host/compile-jvm-interface]))) -- cgit v1.2.3 From 8003120870b877264afcfc5bc785453ae55e2a7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 5 Feb 2017 23:12:18 -0400 Subject: - Added support for compiling _lux_proc (some procedures). - Added support for compiling (some) procedures, captured-variables, iteration, if-expressions and get-expressions. - Fixed some bugs. --- luxc/src/lux/analyser.clj | 5 +- luxc/src/lux/analyser/jvm.clj | 73 ++++++++ luxc/src/lux/analyser/proc.clj | 285 +++++++++++++++++++++++++++++ luxc/src/lux/base.clj | 113 ++++++------ luxc/src/lux/compiler/js.clj | 22 +-- luxc/src/lux/compiler/js/base.clj | 3 + luxc/src/lux/compiler/js/lux.clj | 169 ++++++++--------- luxc/src/lux/compiler/js/proc.clj | 364 +++++++++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/host.clj | 104 +++++++++-- 9 files changed, 968 insertions(+), 170 deletions(-) create mode 100644 luxc/src/lux/analyser/proc.clj create mode 100644 luxc/src/lux/compiler/js/proc.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index b611c1f80..977911c28 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -10,6 +10,7 @@ (lux.analyser [base :as &&] [lux :as &&lux] [jvm :as &&jvm] + [proc :as &&proc] [module :as &&module] [parser :as &&a-parser]))) @@ -132,7 +133,9 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args))) + (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args) + )) "_lux_:" (|let [(&/$Cons ?type diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj index b82c634d6..6146551ef 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/jvm.clj @@ -1068,6 +1068,15 @@ ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg @@ -1075,6 +1084,15 @@ ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -1105,7 +1123,11 @@ (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real ) (do-template [ ] @@ -1119,8 +1141,16 @@ ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + + ;; TODO: USE COMMON PROC ANALYSIS + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] ) (do-template [ ] @@ -1141,6 +1171,22 @@ ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] ) +;; TODO: USE COMMON PROC ANALYSIS +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) +;; TODO: USE COMMON PROC ANALYSIS + (defn analyse-host [analyse exo-type compilers category proc ?values] (|let [[_ _ _ compile-class compile-interface] compilers] (case category @@ -1148,6 +1194,11 @@ (case proc "==" (analyse-lux-== analyse exo-type ?values)) + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + "bit" (case proc "count" (analyse-bit-count analyse exo-type ?values) @@ -1202,11 +1253,33 @@ "int" (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) "to-nat" (analyse-int-to-nat analyse exo-type ?values) ) "real" (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + "decode" (analyse-real-decode analyse exo-type ?values) + "min-value" (analyse-real-min-value analyse exo-type ?values) + "max-value" (analyse-real-max-value analyse exo-type ?values) "to-deg" (analyse-real-to-deg analyse exo-type ?values) ) diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc.clj new file mode 100644 index 000000000..a71a1a9e5 --- /dev/null +++ b/luxc/src/lux/analyser/proc.clj @@ -0,0 +1,285 @@ +(ns lux.analyser.proc + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) + +;; (do-template [ ] +;; (defn [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] +;; =mask (&&/analyse-1 analyse &type/Nat mask) +;; =input (&&/analyse-1 analyse &type/Nat input) +;; _ (&type/check exo-type &type/Nat) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + +;; ^:private analyse-bit-and "and" +;; ^:private analyse-bit-or "or" +;; ^:private analyse-bit-xor "xor" +;; ) + +;; (defn ^:private analyse-bit-count [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Nil)) ?values] +;; =input (&&/analyse-1 analyse &type/Nat input) +;; _ (&type/check exo-type &type/Nat) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +;; (do-template [ ] +;; (defn [analyse exo-type ?values] +;; (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] +;; =shift (&&/analyse-1 analyse &type/Nat shift) +;; =input (&&/analyse-1 analyse input) +;; _ (&type/check exo-type ) +;; _cursor &/cursor] +;; (return (&/|list (&&/|meta exo-type _cursor +;; (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + +;; ^:private analyse-bit-shift-left "shift-left" &type/Nat +;; ^:private analyse-bit-shift-right "shift-right" &type/Int +;; ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat +;; ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg + ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg + ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg + ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg + ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg + ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool + ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + ) + +(defn ^:private analyse-deg-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Deg x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Deg) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Deg _cursor + (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int + ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ) + +(defn analyse-proc [analyse exo-type category proc ?values] + (case category + ;; "lux" + ;; (case proc + ;; "==" (analyse-lux-== analyse exo-type ?values)) + + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + + ;; "bit" + ;; (case proc + ;; "count" (analyse-bit-count analyse exo-type ?values) + ;; "and" (analyse-bit-and analyse exo-type ?values) + ;; "or" (analyse-bit-or analyse exo-type ?values) + ;; "xor" (analyse-bit-xor analyse exo-type ?values) + ;; "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + ;; "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + ;; "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + ;; "array" + ;; (case proc + ;; "new" (analyse-array-new analyse exo-type ?values) + ;; "get" (analyse-array-get analyse exo-type ?values) + ;; "put" (analyse-jvm-aastore analyse exo-type ?values) + ;; "remove" (analyse-array-remove analyse exo-type ?values) + ;; "size" (analyse-jvm-arraylength analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "int" + (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "deg" + (case proc + "+" (analyse-deg-add analyse exo-type ?values) + "-" (analyse-deg-sub analyse exo-type ?values) + "*" (analyse-deg-mul analyse exo-type ?values) + "/" (analyse-deg-div analyse exo-type ?values) + "%" (analyse-deg-rem analyse exo-type ?values) + "=" (analyse-deg-eq analyse exo-type ?values) + "<" (analyse-deg-lt analyse exo-type ?values) + ;; "encode" (analyse-deg-encode analyse exo-type ?values) + ;; "decode" (analyse-deg-decode analyse exo-type ?values) + ;; "min-value" (analyse-deg-min-value analyse exo-type ?values) + ;; "max-value" (analyse-deg-max-value analyse exo-type ?values) + ;; "to-real" (analyse-deg-to-real analyse exo-type ?values) + ;; "scale" (analyse-deg-scale analyse exo-type ?values) + ) + + "real" + (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + ;; "decode" (analyse-real-decode analyse exo-type ?values) + ;; "min-value" (analyse-real-min-value analyse exo-type ?values) + ;; "max-value" (analyse-real-max-value analyse exo-type ?values) + ;; "to-deg" (analyse-real-to-real analyse exo-type ?values) + ) + + ;; "char" + ;; (case proc + ;; "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ;; ) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 6ab09166e..1c34926aa 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -4,6 +4,11 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) +(def !log! (atom false)) +(defn flag-prn! [& args] + (when @!log! + (apply prn args))) + ;; [Tags] (def unit-tag (.intern (str (char 0) "unit" (char 0)))) @@ -1019,13 +1024,13 @@ (let [clean-separators (fn [^String input] (.replaceAll input "_" "")) deg-text-to-digits (fn [^String input] - (loop [output (vec (repeat deg-bits 0)) - index (dec (.length input))] - (if (>= index 0) - (let [digit (Byte/parseByte (.substring input index (inc index)))] - (recur (assoc output index digit) - (dec index))) - output))) + (loop [output (vec (repeat deg-bits 0)) + index (dec (.length input))] + (if (>= index 0) + (let [digit (Byte/parseByte (.substring input index (inc index)))] + (recur (assoc output index digit) + (dec index))) + output))) times5 (fn [index digits] (loop [index index carry 0 @@ -1037,58 +1042,58 @@ (assoc digits index (rem raw 10)))) digits))) deg-digit-power (fn [level] - (loop [output (-> (vec (repeat deg-bits 0)) - (assoc level 1)) - times level] - (if (>= times 0) - (recur (times5 level output) - (dec times)) - output))) + (loop [output (-> (vec (repeat deg-bits 0)) + (assoc level 1)) + times level] + (if (>= times 0) + (recur (times5 level output) + (dec times)) + output))) deg-digits-lt (fn deg-digits-lt - ([subject param index] - (and (< index deg-bits) - (or (< (get subject index) - (get param index)) - (and (= (get subject index) - (get param index)) - (deg-digits-lt subject param (inc index)))))) - ([subject param] - (deg-digits-lt subject param 0))) + ([subject param index] + (and (< index deg-bits) + (or (< (get subject index) + (get param index)) + (and (= (get subject index) + (get param index)) + (deg-digits-lt subject param (inc index)))))) + ([subject param] + (deg-digits-lt subject param 0))) deg-digits-sub-once (fn [subject param-digit index] - (if (>= (get subject index) - param-digit) - (update-in subject [index] #(- % param-digit)) - (recur (update-in subject [index] #(- 10 (- param-digit %))) - 1 - (dec index)))) + (if (>= (get subject index) + param-digit) + (update-in subject [index] #(- % param-digit)) + (recur (update-in subject [index] #(- 10 (- param-digit %))) + 1 + (dec index)))) deg-digits-sub (fn [subject param] - (loop [target subject - index (dec deg-bits)] - (if (>= index 0) - (recur (deg-digits-sub-once target (get param index) index) - (dec index)) - target))) + (loop [target subject + index (dec deg-bits)] + (if (>= index 0) + (recur (deg-digits-sub-once target (get param index) index) + (dec index)) + target))) deg-digits-to-text (fn [digits] - (loop [output "" - index (dec deg-bits)] - (if (>= index 0) - (recur (-> (get digits index) - (Character/forDigit 10) - (str output)) - (dec index)) - output))) + (loop [output "" + index (dec deg-bits)] + (if (>= index 0) + (recur (-> (get digits index) + (Character/forDigit 10) + (str output)) + (dec index)) + output))) add-deg-digit-powers (fn [dl dr] - (loop [index (dec deg-bits) - output (vec (repeat deg-bits 0)) - carry 0] - (if (>= index 0) - (let [raw (+ carry - (get dl index) - (get dr index))] - (recur (dec index) - (assoc output index (rem raw 10)) - (int (/ raw 10)))) - output)))] + (loop [index (dec deg-bits) + output (vec (repeat deg-bits 0)) + carry 0] + (if (>= index 0) + (let [raw (+ carry + (get dl index) + (get dr index))] + (recur (dec index) + (assoc output index (rem raw 10)) + (int (/ raw 10)))) + output)))] ;; Based on the LuxRT.encode_deg method (defn encode-deg [input] (if (= 0 input) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 8901bc154..6aa5d5915 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -22,7 +22,7 @@ ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - ;; [host :as &&host] + [proc :as &&proc] ) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory @@ -62,8 +62,8 @@ (&o/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?idx) - ;; (&o/$captured ?scope ?captured-id ?source) - ;; (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + (&o/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) (&o/$var (&/$Global ?module ?name)) (&&lux/compile-global ?module ?name) @@ -74,8 +74,8 @@ ;; (&o/$loop _register-offset _inits _body) ;; (&&lux/compile-loop compile-expression _register-offset _inits _body) - ;; (&o/$iter _register-offset ?args) - ;; (&&lux/compile-iter compile-expression _register-offset ?args) + (&o/$iter _register-offset ?args) + (&&lux/compile-iter compile-expression _register-offset ?args) (&o/$variant ?tag ?tail ?members) (&&lux/compile-variant compile-expression ?tag ?tail ?members) @@ -86,11 +86,11 @@ (&o/$let _value _register _body) (&&lux/compile-let compile-expression _value _register _body) - ;; (&o/$record-get _value _path) - ;; (&&lux/compile-record-get compile-expression _value _path) + (&o/$record-get _value _path) + (&&lux/compile-record-get compile-expression _value _path) - ;; (&o/$if _test _then _else) - ;; (&&lux/compile-if compile-expression _test _then _else) + (&o/$if _test _then _else) + (&&lux/compile-if compile-expression _test _then _else) (&o/$function _register-offset ?arity ?scope ?env ?body) (&&lux/compile-function compile-expression ?arity ?scope ?env ?body) @@ -98,8 +98,8 @@ (&o/$ann ?value-ex ?type-ex) (compile-expression ?value-ex) - ;; (&o/$proc [?proc-category ?proc-name] ?args special-args) - ;; (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args) + (&o/$proc [?proc-category ?proc-name] ?args special-args) + (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args) _ (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index f89bbb9a2..b88d4dc00 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -93,6 +93,9 @@ (instance? java.lang.String js-object)) js-object + (instance? java.lang.Number js-object) + (long js-object) + (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 3324a83c7..578eb74f8 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -22,6 +22,9 @@ (defn ^:private js-var-name [module name] (str (string/replace module "/" "$") "$" (&host/def-name name))) +(defn ^:private captured-name [register] + (str "$" register)) + (defn ^:private register-name [register] (str "_" register)) @@ -31,7 +34,7 @@ (do-template [] (defn [value] - (return (str value "|0"))) + (return (str "(" value "|0)"))) compile-nat compile-int @@ -70,16 +73,8 @@ (defn compile-local [compile register] (return (register-name register))) -;; (defn compile-captured [compile ?scope ?captured-id ?source] -;; (|do [:let [??scope (&/|reverse ?scope)] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitFieldInsn Opcodes/GETFIELD -;; (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) -;; (str &&/closure-prefix ?captured-id) -;; "Ljava/lang/Object;"))]] -;; (return nil))) +(defn compile-captured [compile ?scope ?captured-id ?source] + (return (captured-name ?captured-id))) (defn compile-global [module name] (return (js-var-name module name))) @@ -105,38 +100,31 @@ ;; (compile-expression $begin body) ;; )) -;; (defn compile-iter [compile $begin register-offset ?args] -;; (|do [^MethodVisitor *writer* &/get-writer -;; :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) -;; ?args)] -;; _ (&/map% (fn [idx+?arg] -;; (|do [:let [[idx ?arg] idx+?arg -;; idx+ (+ register-offset idx) -;; already-set? (|case ?arg -;; [_ (&o/$var (&/$Local l-idx))] -;; (= idx+ l-idx) - -;; _ -;; false)]] -;; (if already-set? -;; (return nil) -;; (compile ?arg)))) -;; idxs+args) -;; _ (&/map% (fn [idx+?arg] -;; (|do [:let [[idx ?arg] idx+?arg -;; idx+ (+ register-offset idx) -;; already-set? (|case ?arg -;; [_ (&o/$var (&/$Local l-idx))] -;; (= idx+ l-idx) - -;; _ -;; false)] -;; :let [_ (when (not already-set?) -;; (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] -;; (return nil))) -;; (&/|reverse idxs+args)) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] -;; (return nil))) +(defn compile-iter [compile register-offset ?args] + ;; Can only optimize if it is a simple expression. + ;; Won't work if it's inside an 'if', unlike on the JVM. + ;; (|do [[updates _] (&/fold% (fn [updates+offset ?arg] + ;; (|let [[updates offset] updates+offset + ;; already-set? (|case ?arg + ;; [_ (&o/$var (&/$Local l-idx))] + ;; (= offset l-idx) + + ;; _ + ;; false)] + ;; (if already-set? + ;; (return (&/T [updates (inc offset)])) + ;; (|do [=arg (compile ?arg)] + ;; (return (&/T [(str updates + ;; (register-name offset) " = " =arg ";") + ;; (inc offset)])))))) + ;; (&/T ["" register-offset]) + ;; ?args)] + ;; (return updates)) + (|do [=args (&/map% compile ?args)] + (return (str "_0(" + (->> =args (&/|interpose ",") (&/fold str "")) + ")"))) + ) (defn compile-let [compile _value _register _body] (|do [=value (compile _value) @@ -146,35 +134,20 @@ " return " =body ";})()")))) -;; (defn compile-record-get [compile _value _path] -;; (|do [^MethodVisitor *writer* &/get-writer -;; _ (compile _value) -;; :let [_ (&/|map (fn [step] -;; (|let [[idx tail?] step] -;; (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") -;; (.visitLdcInsn (int idx)) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" -;; (if tail? "product_getRight" "product_getLeft") -;; "([Ljava/lang/Object;I)Ljava/lang/Object;")))) -;; _path)]] -;; (return nil))) - -;; (defn compile-if [compile _test _then _else] -;; (|do [^MethodVisitor *writer* &/get-writer -;; _ (compile _test) -;; :let [$else (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; &&/unwrap-boolean -;; (.visitJumpInsn Opcodes/IFEQ $else))] -;; _ (compile _then) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] -;; :let [_ (.visitLabel *writer* $else)] -;; _ (compile _else) -;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) -;; _ (.visitLabel *writer* $end)]] -;; (return nil))) +(defn compile-record-get [compile _value _path] + (|do [=value (compile _value)] + (return (&/fold (fn [source step] + (|let [[idx tail?] step + method (if tail? "product_getRight" "product_getLeft")] + (str &&rt/LuxRT "." method "(" source "," idx ")"))) + (str "(" =value ")") + _path)))) + +(defn compile-if [compile _test _then _else] + (|do [=test (compile _test) + =then (compile _then) + =else (compile _else)] + (return (str "(" =test " ? " =then " : " =else ")")))) (def ^:private savepoint "pm_cursor_savepoint") (def ^:private cursor "pm_cursor") @@ -307,27 +280,39 @@ func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) (&/fold str ""))] + =env (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (|do [=source (compile ?source)] + (return (str "var " (captured-name ?captured-id) " = " =source ";"))))) + (&/|vals ?env)) =body (compile ?body)] - (return (str "(function " function-name "() {" - "\"use strict\";" - "var num_args = arguments.length;" - "if(num_args == " arity ") {" - "var " (register-name 0) " = " function-name ";" - func-args - "return " =body ";" - "}" - "else if(num_args > " arity ") {" - "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" - ".apply(null, [].slice.call(arguments," arity "));" - "}" - ;; Less than arity - "else {" - "var curried = [].slice.call(arguments);" - "return function() { " - "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" - " };" - "}" - "})")))) + (return (str "(function() {" + (->> =env (&/fold str "")) + "return " + (str "(function " function-name "() {" + "\"use strict\";" + "var num_args = arguments.length;" + "if(num_args == " arity ") {" + "var " (register-name 0) " = " function-name ";" + func-args + (str "while(true) {" + "return " =body ";" + "}") + "}" + "else if(num_args > " arity ") {" + "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" + ".apply(null, [].slice.call(arguments," arity "));" + "}" + ;; Less than arity + "else {" + "var curried = [].slice.call(arguments);" + "return function() { " + "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" + " };" + "}" + "})") + ";})()")))) (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc.clj new file mode 100644 index 000000000..95e6950da --- /dev/null +++ b/luxc/src/lux/compiler/js/proc.clj @@ -0,0 +1,364 @@ +(ns lux.compiler.js.proc + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &o]) + [lux.analyser.base :as &a] + [lux.compiler.js.base :as &&])) + +;; [Resources] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?mask) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-and Opcodes/LAND +;; ^:private compile-bit-or Opcodes/LOR +;; ^:private compile-bit-xor Opcodes/LXOR +;; ) + +;; (defn ^:private compile-bit-count [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") +;; (.visitInsn Opcodes/I2L) +;; &&/wrap-long)]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?shift) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitInsn Opcodes/L2I))] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-shift-left Opcodes/LSHL +;; ^:private compile-bit-shift-right Opcodes/LSHR +;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR +;; ) + +;; (defn ^:private compile-lux-== [compile ?values special-args] +;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?left) +;; _ (compile ?right) +;; :let [$then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) +;; ;; else +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") +;; (.visitLabel $end))]] +;; (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x " " " " =y ")")))) + + ^:private compile-nat-add "+" + ^:private compile-nat-sub "-" + ^:private compile-nat-mul "*" + ^:private compile-nat-div "/" + ^:private compile-nat-rem "%" + ^:private compile-nat-eq "===" + ^:private compile-nat-lt "<" + + ^:private compile-int-add "+" + ^:private compile-int-sub "-" + ^:private compile-int-mul "*" + ^:private compile-int-div "/" + ^:private compile-int-rem "%" + ^:private compile-int-eq "===" + ^:private compile-int-lt "<" + + ^:private compile-deg-add "+" + ^:private compile-deg-sub "-" + ^:private compile-deg-mul "*" + ^:private compile-deg-div "/" + ^:private compile-deg-rem "%" + ^:private compile-deg-eq "===" + ^:private compile-deg-lt "<" + ^:private compile-deg-scale "*" + + ^:private compile-real-add "+" + ^:private compile-real-sub "-" + ^:private compile-real-mul "*" + ^:private compile-real-div "/" + ^:private compile-real-rem "%" + ^:private compile-real-eq "===" + ^:private compile-real-lt "<" + ) + +;; (defn ^:private compile-nat-lt [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long) +;; $then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitLdcInsn (int -1)) +;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitLabel $end))]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Nil) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; :let [_ (doto *writer* +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + +;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long +;; ) + +;; (do-template [ ] +;; (do (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] +;; (return nil))) + +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] +;; (return nil))))) + +;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" +;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" +;; ) + +(defn compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").toString()")))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-deg-mul "mul_deg" +;; ^:private compile-deg-div "div_deg" +;; ) + +;; (do-template [ ] +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) +;; )]] +;; (return nil)))) + +;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double +;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long +;; ) + +;; (let [widen (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/I2L))) +;; shrink (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/L2I) +;; (.visitInsn Opcodes/I2C)))] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink +;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen +;; )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x "===" =y ")")))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str =x ".concat(" =y ")")))) + +(defn compile-proc [compile proc-category proc-name ?values special-args] + (case proc-category + ;; "lux" + ;; (case proc-name + ;; "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) + + ;; "bit" + ;; (case proc-name + ;; "count" (compile-bit-count compile ?values special-args) + ;; "and" (compile-bit-and compile ?values special-args) + ;; "or" (compile-bit-or compile ?values special-args) + ;; "xor" (compile-bit-xor compile ?values special-args) + ;; "shift-left" (compile-bit-shift-left compile ?values special-args) + ;; "shift-right" (compile-bit-shift-right compile ?values special-args) + ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + ;; "array" + ;; (case proc-name + ;; "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + ;; "encode" (compile-nat-encode compile ?values special-args) + ;; "decode" (compile-nat-decode compile ?values special-args) + ;; "max-value" (compile-nat-max-value compile ?values special-args) + ;; "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + ;; "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "int" + (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) + ;; "decode" (compile-int-decode compile ?values special-args) + ;; "max-value" (compile-int-max-value compile ?values special-args) + ;; "min-value" (compile-int-min-value compile ?values special-args) + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + ;; "encode" (compile-deg-encode compile ?values special-args) + ;; "decode" (compile-deg-decode compile ?values special-args) + ;; "max-value" (compile-deg-max-value compile ?values special-args) + ;; "min-value" (compile-deg-min-value compile ?values special-args) + ;; "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "real" + (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + ;; "encode" (compile-real-encode compile ?values special-args) + ;; "decode" (compile-real-decode compile ?values special-args) + ;; "max-value" (compile-real-max-value compile ?values special-args) + ;; "min-value" (compile-real-min-value compile ?values special-args) + ;; "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + ;; "char" + ;; (case proc-name + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ;; ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj index 34a5a2bb7..9583c3106 100644 --- a/luxc/src/lux/compiler/jvm/host.clj +++ b/luxc/src/lux/compiler/jvm/host.clj @@ -1954,6 +1954,12 @@ (.visitLabel $end))]] (return nil))) + ^:private compile-int-eq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long + + ^:private compile-real-eq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double + ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long @@ -2383,29 +2389,41 @@ (.visitLabel $end))]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) :let [_ (doto *writer* - &&/unwrap-long)] + )] _ (compile ?y) :let [_ (doto *writer* - &&/unwrap-long) + ) _ (doto *writer* (.visitInsn ) - &&/wrap-long)]] + )]] (return nil))) - ^:private compile-nat-add Opcodes/LADD - ^:private compile-nat-sub Opcodes/LSUB - ^:private compile-nat-mul Opcodes/LMUL - - ^:private compile-deg-add Opcodes/LADD - ^:private compile-deg-sub Opcodes/LSUB - ^:private compile-deg-rem Opcodes/LSUB - ^:private compile-deg-scale Opcodes/LMUL + ^:private compile-int-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-int-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-nat-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double ) (do-template [ ] @@ -2518,6 +2536,24 @@ ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" ) +(defn ^:private compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-real-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -2586,11 +2622,39 @@ ^:private compile-int-to-nat ) +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + _ (compile ?y) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] + (return nil))) + (defn compile-host [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) "bit" (case proc-name @@ -2642,11 +2706,27 @@ "int" (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) ) "real" (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) ) -- cgit v1.2.3 From 66ceed37b71921e14cae8a091df7738d9e587c2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 7 Feb 2017 19:38:58 -0400 Subject: - Reorganized the code related to _lux_proc a bit. - Implemented some of the low-level machinery for 64-bit integers. --- luxc/src/lux/analyser.clj | 13 +- luxc/src/lux/analyser/jvm.clj | 1432 ------------------------------ luxc/src/lux/analyser/proc.clj | 285 ------ luxc/src/lux/analyser/proc/common.clj | 288 ++++++ luxc/src/lux/analyser/proc/jvm.clj | 1144 ++++++++++++++++++++++++ luxc/src/lux/base.clj | 10 +- luxc/src/lux/compiler/js.clj | 14 +- luxc/src/lux/compiler/js/base.clj | 56 +- luxc/src/lux/compiler/js/lux.clj | 6 +- luxc/src/lux/compiler/js/proc.clj | 364 -------- luxc/src/lux/compiler/js/proc/common.clj | 373 ++++++++ luxc/src/lux/compiler/js/rt.clj | 173 +++- luxc/src/lux/type.clj | 16 +- 13 files changed, 2016 insertions(+), 2158 deletions(-) delete mode 100644 luxc/src/lux/analyser/jvm.clj delete mode 100644 luxc/src/lux/analyser/proc.clj create mode 100644 luxc/src/lux/analyser/proc/common.clj create mode 100644 luxc/src/lux/analyser/proc/jvm.clj delete mode 100644 luxc/src/lux/compiler/js/proc.clj create mode 100644 luxc/src/lux/compiler/js/proc/common.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 977911c28..f5a200cad 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -9,10 +9,10 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [jvm :as &&jvm] - [proc :as &&proc] [module :as &&module] - [parser :as &&a-parser]))) + [parser :as &&a-parser]) + (lux.analyser.proc [common :as &&common] + [jvm :as &&jvm]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -133,8 +133,11 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) - ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args) + (case ?category + "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + ;; "js" + ;; common + (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) "_lux_:" diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj deleted file mode 100644 index 6146551ef..000000000 --- a/luxc/src/lux/analyser/jvm.clj +++ /dev/null @@ -1,1432 +0,0 @@ -(ns lux.analyser.jvm - (:require (clojure [template :refer [do-template]] - [string :as string]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type] - [host :as &host] - [lexer :as &lexer] - [parser :as &parser] - [reader :as &reader]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &&] - [lambda :as &&lambda] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.jvm.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn ^:private ensure-catching [exceptions*] - "(-> (List Text) (Lux Null))" - (|do [class-loader &/loader] - (fn [state] - (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) - catching (->> state - (&/get$ &/$catching) - (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev ^Class now] - (or prev - (cond (or (.isAssignableFrom java.lang.RuntimeException now) - (.isAssignableFrom java.lang.Error now)) - nil - - (&/fold (fn [found? ^Class ex-catch] - (or found? - (.isAssignableFrom ex-catch now))) - false - catching) - nil - - :else - now))) - nil - exceptions)] - ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) - state) - (&/return* state nil))) - ))) - -(defn ^:private with-catches [catches body] - "(All [a] (-> (List Text) (Lux a) (Lux a)))" - (fn [state] - (let [old-catches (&/get$ &/$catching state) - state* (&/update$ &/$catching (partial &/|++ catches) state)] - (|case (&/run-state body state*) - (&/$Left msg) - (&/$Left msg) - - (&/$Right state** output) - (&/$Right (&/T [(&/set$ &/$catching old-catches state**) - output])))) - )) - -(defn ^:private ensure-object [type] - "(-> Type (Lux (, Text (List Type))))" - (|case type - (&/$HostT payload) - (return payload) - - (&/$VarT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$ExT id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$NamedT _ type*) - (ensure-object type*) - - (&/$UnivQ _ type*) - (ensure-object type*) - - (&/$ExQ _ type*) - (ensure-object type*) - - (&/$AppT F A) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) - -(defn ^:private as-object [type] - "(-> Type Type)" - (|case type - (&/$HostT class params) - (&/$HostT (&host-type/as-obj class) params) - - _ - type)) - -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - -(defn ^:private as-otype+ [type] - "(-> Type Type)" - (|case type - (&/$HostT name params) - (&/$HostT (as-otype name) params) - - _ - type)) - -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/$Cons real-type types)])))) - (&/T [1 &/$Nil]) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&/$UnivQ &type/empty-env base-type) - - _ - base-type)) - (&/$HostT class-name type-args) - type-args)) - -;; [Resources] -(defn ^:private analyse-field-access-helper [obj-type gvars gtype] - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - (|case obj-type - (&/$HostT class targs) - (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - gvars - targs)] - (&host-type/instance-param &type/existential gtype-env gtype)) - (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) - -(defn generic-class->simple-class [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar var-name) - "java.lang.Object" - - (&/$GenericWildcard _) - "java.lang.Object" - - (&/$GenericClass name params) - name - - (&/$GenericArray param) - (|case param - (&/$GenericArray _) - (str "[" (generic-class->simple-class param)) - - (&/$GenericClass "boolean" _) - "[Z" - - (&/$GenericClass "byte" _) - "[B" - - (&/$GenericClass "short" _) - "[S" - - (&/$GenericClass "int" _) - "[I" - - (&/$GenericClass "long" _) - "[J" - - (&/$GenericClass "float" _) - "[F" - - (&/$GenericClass "double" _) - "[D" - - (&/$GenericClass "char" _) - "[C" - - (&/$GenericClass name params) - (str "[L" name ";") - - (&/$GenericTypeVar var-name) - "[Ljava.lang.Object;" - - (&/$GenericWildcard _) - "[Ljava.lang.Object;") - )) - -(defn generic-class->type [env gclass] - "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" - (|case gclass - (&/$GenericTypeVar var-name) - (if-let [ex (&/|get var-name env)] - (return ex) - (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) - - (&/$GenericClass name params) - (case name - "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) - "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) - "short" (return (&/$HostT "java.lang.Short" &/$Nil)) - "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) - "long" (return (&/$HostT "java.lang.Long" &/$Nil)) - "float" (return (&/$HostT "java.lang.Float" &/$Nil)) - "double" (return (&/$HostT "java.lang.Double" &/$Nil)) - "char" (return (&/$HostT "java.lang.Character" &/$Nil)) - "void" (return &/$UnitT) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$HostT name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) - - (&/$GenericWildcard _) - (return (&/$ExQ &/$Nil (&/$BoundT 1))) - )) - -(defn gen-super-env [class-env supers class-decl] - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - (|let [[class-name class-vars] class-decl] - (|case (&/|some (fn [super] - (|let [[super-name super-params] super] - (if (= class-name super-name) - (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) - &/$None))) - supers) - (&/$None) - (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) - - (&/$Some vars+gtypes) - (&/map% (fn [var+gtype] - (|do [:let [[var gtype] var+gtype] - =gtype (generic-class->type class-env gtype)] - (return (&/T [var =gtype])))) - vars+gtypes) - ))) - -(defn ^:private make-type-env [type-params] - "(-> (List TypeParam) (Lux (List [Text Type])))" - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn ^:private double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn ^:private method-input-folder [full-env] - (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (if (double-register-gclass? itype*) - (&&env/with-local iname itype - (&&env/with-local "" &/$VoidT - body*)) - (&&env/with-local iname itype - body*))))) - -(defn ^:private analyse-method [analyse class-decl class-env all-supers method] - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - (|let [[?cname ?cparams] class-decl - class-type (&/$HostT ?cname (&/|map &/|second class-env))] - (|case method - (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - :let [output-type &/$UnitT] - =ctor-args (&/map% (fn [ctor-arg] - (|do [:let [[ca-type ca-term] ctor-arg] - =ca-type (generic-class->type full-env ca-type) - =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T [ca-type =ca-term])))) - ?ctor-args) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - - (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (make-type-env ?gvars) - :let [full-env (&/|++ super-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))))] - (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env method-env] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&/with-no-catches - (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs)))))] - (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - - (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - ))) - -(defn ^:private mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn ^:private check-method-completion [supers methods] - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - (|do [abstract-methods (mandatory-methods supers) - :let [methods-map (&/fold (fn [mmap mentry] - (|case mentry - (&/$ConstructorMethodAnalysis _) - mmap - - (&/$VirtualMethodAnalysis _) - mmap - - (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) - - (&/$StaticMethodAnalysis _) - mmap - - (&/$AbstractMethodSyntax _) - mmap - - (&/$NativeMethodSyntax _) - mmap - )) - {} - methods) - missing-method (&/fold (fn [missing abs-meth] - (or missing - (|let [[am-name am-inputs] abs-meth] - (if-let [meth-struct (get methods-map am-name)] - (if (some (fn [=inputs] - (and (= (&/|length =inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] - (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) - true - =inputs am-inputs))) - meth-struct) - nil - abs-meth) - abs-meth)))) - nil - abstract-methods)]] - (if (nil? missing-method) - (return nil) - (|let [[am-name am-inputs] missing-method] - (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) - -(defn ^:private analyse-field [analyse gtype-env field] - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) - =value (&&/analyse-1 analyse =gtype ?value)] - (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) - - (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) - (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) - )) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type _?value] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) - - ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" - ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" - ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" - - ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" - ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" - ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" - - ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" - ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" - ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" - ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" - ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" - - ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" - ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" - ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" - ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" - ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" - - ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" - ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" - ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" - ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" - - ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" - - ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [ ] - (let [output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] - =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) - =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) - - ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [ ] - (let [input-type (&/$HostT &/$Nil) - output-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse input-type x) - =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) - - ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" - ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" - - ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" - ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" - - ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" - ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" - - ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" - ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" - - ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" - ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" - ) - -(let [length-type &type/Nat - idx-type &type/Nat] - (do-template [ ] - (let [elem-type (&/$HostT &/$Nil) - array-type (&/$HostT &/$Nil)] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) - - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn ^:private array-class? [class-name] - (or (= &host-type/array-data-tag class-name) - (case class-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true - ;; else - false))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] - gclass (&reader/with-source "jvm-anewarray" _gclass - &&a-parser/parse-gclass) - gtype-env &/get-type-env - =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type inner-arr-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse inner-arr-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Nil)) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn ^:private analyse-jvm-null? [analyse exo-type ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) - -(defn ^:private analyse-jvm-null [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-synchronized [analyse exo-type ?values] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - =expr (&&/analyse-1 analyse exo-type ?expr) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(defn ^:private analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _ (ensure-catching (&/|list throw-class)) - _cursor &/cursor - _ (&type/check exo-type &type/Bottom)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Nil) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - =type (&host-type/instance-param &type/existential &/$Nil gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Nil)) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader !class! field) - =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons value (&/$Nil)) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential &/$Nil gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - :let [obj-type (&&/expr-type* =object)] - _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (analyse-field-access-helper obj-type gvars gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &/$UnitT] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret) - _ (&type/check exo-type (as-otype+ =gret))] - (return (&/T [=gret =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [(&/$VarT _id) $var - gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] - (do-template [ ] - (defn [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Cons object args) ?values] - class-loader &/loader - _ (try (assert! (let [=class (Class/forName !class! true class-loader)] - (= (.isInterface =class))) - (if - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) - [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) - (&host/lookup-virtual-method class-loader !class! method classes)) - _ (ensure-catching exceptions) - =object (&&/analyse-1+ analyse object) - [sub-class sub-params] (ensure-object (&&/expr-type* =object)) - (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params) - :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) - - ^:private analyse-jvm-invokevirtual "invokevirtual" false - ^:private analyse-jvm-invokespecial "invokespecial" false - ^:private analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) - _ (ensure-catching exceptions) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$Nil) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Cons ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) - _ (ensure-catching exceptions) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn ^:private analyse-jvm-try [analyse exo-type ?values] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] - =body (with-catches (&/|list "java.lang.Exception") - (&&/analyse-1 analyse exo-type ?body)) - =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) - -(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] - (|do [:let [(&/$Cons object (&/$Nil)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bool] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] - (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] - ^ClassLoader class-loader &/loader - _ (try (do (.loadClass class-loader _class-name) - (return nil)) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) - :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-interface interface-decl supers =anns =methods) - :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list))))))) - -(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Cons super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) - _ &/pop-dummy-name - :let [_ (println 'CLASS full-name)] - _cursor &/cursor] - (return (&/|list (&&/|meta &/$UnitT _cursor - (&&/$tuple (&/|list)))))))) - -(defn ^:private captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$TupleS &/$Nil)])) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] - (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [module &/get-module-name - scope &/get-scope-name - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$Nil]) - anon-class (str (string/replace module "/" ".") "." name) - anon-class-type (&/$HostT anon-class &/$Nil)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Cons default-) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) - :let [all-supers (&/$Cons super-class interfaces) - class-env &/$Nil] - =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) - _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars - :let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$Nil - captured-slot-type))) - (&/enumerate =captured))] - :let [sources (&/|map captured-source =captured)] - _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) - _ &/pop-dummy-name - _cursor &/cursor] - (return (&/|list (&&/|meta anon-class-type _cursor - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) - ))) - )))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Nat mask) - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - - ^:private analyse-bit-and "and" - ^:private analyse-bit-or "or" - ^:private analyse-bit-xor "xor" - ) - -(defn ^:private analyse-bit-count [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse input) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat - ) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-add ["int" "+"] &type/Int &type/Int - ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int - ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int - ^:private analyse-int-div ["int" "/"] &type/Int &type/Int - ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int - ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool - ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool - - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-add ["real" "+"] &type/Real &type/Real - ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real - ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real - ^:private analyse-real-div ["real" "/"] &type/Real &type/Real - ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real - ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool - ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool - ) - -(defn ^:private analyse-deg-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor - (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int - ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] - - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - - ;; TODO: USE COMMON PROC ANALYSIS - ^:private analyse-real-min-value &type/Real ["real" "min-value"] - ^:private analyse-real-max-value &type/Real ["real" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ) - -;; TODO: USE COMMON PROC ANALYSIS -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool - ^:private analyse-text-append ["text" "append"] &type/Text &type/Text - ) -;; TODO: USE COMMON PROC ANALYSIS - -(defn analyse-host [analyse exo-type compilers category proc ?values] - (|let [[_ _ _ compile-class compile-interface] compilers] - (case category - "lux" - (case proc - "==" (analyse-lux-== analyse exo-type ?values)) - - "text" - (case proc - "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) - - "bit" - (case proc - "count" (analyse-bit-count analyse exo-type ?values) - "and" (analyse-bit-and analyse exo-type ?values) - "or" (analyse-bit-or analyse exo-type ?values) - "xor" (analyse-bit-xor analyse exo-type ?values) - "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - "array" - (case proc - "new" (analyse-array-new analyse exo-type ?values) - "get" (analyse-array-get analyse exo-type ?values) - "put" (analyse-jvm-aastore analyse exo-type ?values) - "remove" (analyse-array-remove analyse exo-type ?values) - "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - "encode" (analyse-deg-encode analyse exo-type ?values) - "decode" (analyse-deg-decode analyse exo-type ?values) - "min-value" (analyse-deg-min-value analyse exo-type ?values) - "max-value" (analyse-deg-max-value analyse exo-type ?values) - "to-real" (analyse-deg-to-real analyse exo-type ?values) - "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "int" - (case proc - "+" (analyse-int-add analyse exo-type ?values) - "-" (analyse-int-sub analyse exo-type ?values) - "*" (analyse-int-mul analyse exo-type ?values) - "/" (analyse-int-div analyse exo-type ?values) - "%" (analyse-int-rem analyse exo-type ?values) - "=" (analyse-int-eq analyse exo-type ?values) - "<" (analyse-int-lt analyse exo-type ?values) - "encode" (analyse-int-encode analyse exo-type ?values) - "decode" (analyse-int-decode analyse exo-type ?values) - "min-value" (analyse-int-min-value analyse exo-type ?values) - "max-value" (analyse-int-max-value analyse exo-type ?values) - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "real" - (case proc - "+" (analyse-real-add analyse exo-type ?values) - "-" (analyse-real-sub analyse exo-type ?values) - "*" (analyse-real-mul analyse exo-type ?values) - "/" (analyse-real-div analyse exo-type ?values) - "%" (analyse-real-rem analyse exo-type ?values) - "=" (analyse-real-eq analyse exo-type ?values) - "<" (analyse-real-lt analyse exo-type ?values) - "encode" (analyse-real-encode analyse exo-type ?values) - "decode" (analyse-real-decode analyse exo-type ?values) - "min-value" (analyse-real-min-value analyse exo-type ?values) - "max-value" (analyse-real-max-value analyse exo-type ?values) - "to-deg" (analyse-real-to-deg analyse exo-type ?values) - ) - - "char" - (case proc - "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ) - - "jvm" - (case proc - "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) - "load-class" (analyse-jvm-load-class analyse exo-type ?values) - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "l2s" (analyse-jvm-l2s analyse exo-type ?values) - "l2b" (analyse-jvm-l2b analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - "b2l" (analyse-jvm-b2l analyse exo-type ?values) - "s2l" (analyse-jvm-s2l analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) - - (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) - - (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) - - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc.clj deleted file mode 100644 index a71a1a9e5..000000000 --- a/luxc/src/lux/analyser/proc.clj +++ /dev/null @@ -1,285 +0,0 @@ -(ns lux.analyser.proc - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type]) - (lux.analyser [base :as &&]))) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool - ^:private analyse-text-append ["text" "append"] &type/Text &type/Text - ) - -;; (do-template [ ] -;; (defn [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] -;; =mask (&&/analyse-1 analyse &type/Nat mask) -;; =input (&&/analyse-1 analyse &type/Nat input) -;; _ (&type/check exo-type &type/Nat) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) - -;; ^:private analyse-bit-and "and" -;; ^:private analyse-bit-or "or" -;; ^:private analyse-bit-xor "xor" -;; ) - -;; (defn ^:private analyse-bit-count [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Nil)) ?values] -;; =input (&&/analyse-1 analyse &type/Nat input) -;; _ (&type/check exo-type &type/Nat) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -;; (do-template [ ] -;; (defn [analyse exo-type ?values] -;; (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] -;; =shift (&&/analyse-1 analyse &type/Nat shift) -;; =input (&&/analyse-1 analyse input) -;; _ (&type/check exo-type ) -;; _cursor &/cursor] -;; (return (&/|list (&&/|meta exo-type _cursor -;; (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - -;; ^:private analyse-bit-shift-left "shift-left" &type/Nat -;; ^:private analyse-bit-shift-right "shift-right" &type/Int -;; ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat -;; ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse x) - =y (&&/analyse-1 analyse y) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ^:private analyse-int-add ["int" "+"] &type/Int &type/Int - ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int - ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int - ^:private analyse-int-div ["int" "/"] &type/Int &type/Int - ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int - ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool - ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool - - ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg - ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg - ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg - ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg - ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg - ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool - ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool - - ^:private analyse-real-add ["real" "+"] &type/Real &type/Real - ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real - ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real - ^:private analyse-real-div ["real" "/"] &type/Real &type/Real - ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real - ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool - ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool - ) - -(defn ^:private analyse-deg-scale [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse &type/Deg x) - =y (&&/analyse-1 analyse &type/Nat y) - _ (&type/check exo-type &type/Deg) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor - (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) - -(do-template [ ] - (do (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type &type/Text) - _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - (let [decode-type (&/$AppT &type/Maybe )] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type decode-type) - _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) - - ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat - ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int - ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg - ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list) (&/|list))))))) - - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] - - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - ) - -(do-template [ ] - (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _cursor &/cursor] - (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ) - -(defn analyse-proc [analyse exo-type category proc ?values] - (case category - ;; "lux" - ;; (case proc - ;; "==" (analyse-lux-== analyse exo-type ?values)) - - "text" - (case proc - "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) - - ;; "bit" - ;; (case proc - ;; "count" (analyse-bit-count analyse exo-type ?values) - ;; "and" (analyse-bit-and analyse exo-type ?values) - ;; "or" (analyse-bit-or analyse exo-type ?values) - ;; "xor" (analyse-bit-xor analyse exo-type ?values) - ;; "shift-left" (analyse-bit-shift-left analyse exo-type ?values) - ;; "shift-right" (analyse-bit-shift-right analyse exo-type ?values) - ;; "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - - ;; "array" - ;; (case proc - ;; "new" (analyse-array-new analyse exo-type ?values) - ;; "get" (analyse-array-get analyse exo-type ?values) - ;; "put" (analyse-jvm-aastore analyse exo-type ?values) - ;; "remove" (analyse-array-remove analyse exo-type ?values) - ;; "size" (analyse-jvm-arraylength analyse exo-type ?values)) - - "nat" - (case proc - "+" (analyse-nat-add analyse exo-type ?values) - "-" (analyse-nat-sub analyse exo-type ?values) - "*" (analyse-nat-mul analyse exo-type ?values) - "/" (analyse-nat-div analyse exo-type ?values) - "%" (analyse-nat-rem analyse exo-type ?values) - "=" (analyse-nat-eq analyse exo-type ?values) - "<" (analyse-nat-lt analyse exo-type ?values) - "encode" (analyse-nat-encode analyse exo-type ?values) - "decode" (analyse-nat-decode analyse exo-type ?values) - "min-value" (analyse-nat-min-value analyse exo-type ?values) - "max-value" (analyse-nat-max-value analyse exo-type ?values) - "to-int" (analyse-nat-to-int analyse exo-type ?values) - "to-char" (analyse-nat-to-char analyse exo-type ?values) - ) - - "int" - (case proc - "+" (analyse-int-add analyse exo-type ?values) - "-" (analyse-int-sub analyse exo-type ?values) - "*" (analyse-int-mul analyse exo-type ?values) - "/" (analyse-int-div analyse exo-type ?values) - "%" (analyse-int-rem analyse exo-type ?values) - "=" (analyse-int-eq analyse exo-type ?values) - "<" (analyse-int-lt analyse exo-type ?values) - "encode" (analyse-int-encode analyse exo-type ?values) - "decode" (analyse-int-decode analyse exo-type ?values) - "min-value" (analyse-int-min-value analyse exo-type ?values) - "max-value" (analyse-int-max-value analyse exo-type ?values) - "to-nat" (analyse-int-to-nat analyse exo-type ?values) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - ;; "encode" (analyse-deg-encode analyse exo-type ?values) - ;; "decode" (analyse-deg-decode analyse exo-type ?values) - ;; "min-value" (analyse-deg-min-value analyse exo-type ?values) - ;; "max-value" (analyse-deg-max-value analyse exo-type ?values) - ;; "to-real" (analyse-deg-to-real analyse exo-type ?values) - ;; "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "real" - (case proc - "+" (analyse-real-add analyse exo-type ?values) - "-" (analyse-real-sub analyse exo-type ?values) - "*" (analyse-real-mul analyse exo-type ?values) - "/" (analyse-real-div analyse exo-type ?values) - "%" (analyse-real-rem analyse exo-type ?values) - "=" (analyse-real-eq analyse exo-type ?values) - "<" (analyse-real-lt analyse exo-type ?values) - "encode" (analyse-real-encode analyse exo-type ?values) - ;; "decode" (analyse-real-decode analyse exo-type ?values) - ;; "min-value" (analyse-real-min-value analyse exo-type ?values) - ;; "max-value" (analyse-real-max-value analyse exo-type ?values) - ;; "to-deg" (analyse-real-to-real analyse exo-type ?values) - ) - - ;; "char" - ;; (case proc - ;; "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ;; ) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj new file mode 100644 index 000000000..f6d1eef8e --- /dev/null +++ b/luxc/src/lux/analyser/proc/common.clj @@ -0,0 +1,288 @@ +(ns lux.analyser.proc.common + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(defn ^:private analyse-lux-== [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] + =left (&&/analyse-1 analyse $var left) + =right (&&/analyse-1 analyse $var right) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-append ["text" "append"] &type/Text &type/Text + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) + + ^:private analyse-bit-and "and" + ^:private analyse-bit-or "or" + ^:private analyse-bit-xor "xor" + ) + +(defn ^:private analyse-bit-count [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse input) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) + + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse x) + =y (&&/analyse-1 analyse y) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-int-add ["int" "+"] &type/Int &type/Int + ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int + ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int + ^:private analyse-int-div ["int" "/"] &type/Int &type/Int + ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int + ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool + ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool + + ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg + ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg + ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg + ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg + ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg + ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool + ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool + + ^:private analyse-real-add ["real" "+"] &type/Real &type/Real + ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real + ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real + ^:private analyse-real-div ["real" "/"] &type/Real &type/Real + ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real + ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool + ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + ) + +(defn ^:private analyse-deg-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Deg x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Deg) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Deg _cursor + (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) + + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int + ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg + ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list) (&/|list))))))) + + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] + + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ) + +(defn analyse-proc [analyse exo-type category proc ?values] + (case category + "lux" + (case proc + "==" (analyse-lux-== analyse exo-type ?values)) + + "text" + (case proc + "=" (analyse-text-eq analyse exo-type ?values) + "append" (analyse-text-append analyse exo-type ?values)) + + "bit" + (case proc + "count" (analyse-bit-count analyse exo-type ?values) + "and" (analyse-bit-and analyse exo-type ?values) + "or" (analyse-bit-or analyse exo-type ?values) + "xor" (analyse-bit-xor analyse exo-type ?values) + "shift-left" (analyse-bit-shift-left analyse exo-type ?values) + "shift-right" (analyse-bit-shift-right analyse exo-type ?values) + "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) + + ;; "array" + ;; (case proc + ;; "new" (analyse-array-new analyse exo-type ?values) + ;; "get" (analyse-array-get analyse exo-type ?values) + ;; "put" (analyse-jvm-aastore analyse exo-type ?values) + ;; "remove" (analyse-array-remove analyse exo-type ?values) + ;; "size" (analyse-array-size analyse exo-type ?values)) + + "nat" + (case proc + "+" (analyse-nat-add analyse exo-type ?values) + "-" (analyse-nat-sub analyse exo-type ?values) + "*" (analyse-nat-mul analyse exo-type ?values) + "/" (analyse-nat-div analyse exo-type ?values) + "%" (analyse-nat-rem analyse exo-type ?values) + "=" (analyse-nat-eq analyse exo-type ?values) + "<" (analyse-nat-lt analyse exo-type ?values) + "encode" (analyse-nat-encode analyse exo-type ?values) + "decode" (analyse-nat-decode analyse exo-type ?values) + "min-value" (analyse-nat-min-value analyse exo-type ?values) + "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + "to-char" (analyse-nat-to-char analyse exo-type ?values) + ) + + "int" + (case proc + "+" (analyse-int-add analyse exo-type ?values) + "-" (analyse-int-sub analyse exo-type ?values) + "*" (analyse-int-mul analyse exo-type ?values) + "/" (analyse-int-div analyse exo-type ?values) + "%" (analyse-int-rem analyse exo-type ?values) + "=" (analyse-int-eq analyse exo-type ?values) + "<" (analyse-int-lt analyse exo-type ?values) + "encode" (analyse-int-encode analyse exo-type ?values) + "decode" (analyse-int-decode analyse exo-type ?values) + "min-value" (analyse-int-min-value analyse exo-type ?values) + "max-value" (analyse-int-max-value analyse exo-type ?values) + "to-nat" (analyse-int-to-nat analyse exo-type ?values) + ) + + "deg" + (case proc + "+" (analyse-deg-add analyse exo-type ?values) + "-" (analyse-deg-sub analyse exo-type ?values) + "*" (analyse-deg-mul analyse exo-type ?values) + "/" (analyse-deg-div analyse exo-type ?values) + "%" (analyse-deg-rem analyse exo-type ?values) + "=" (analyse-deg-eq analyse exo-type ?values) + "<" (analyse-deg-lt analyse exo-type ?values) + "encode" (analyse-deg-encode analyse exo-type ?values) + "decode" (analyse-deg-decode analyse exo-type ?values) + "min-value" (analyse-deg-min-value analyse exo-type ?values) + "max-value" (analyse-deg-max-value analyse exo-type ?values) + "to-real" (analyse-deg-to-real analyse exo-type ?values) + "scale" (analyse-deg-scale analyse exo-type ?values) + ) + + "real" + (case proc + "+" (analyse-real-add analyse exo-type ?values) + "-" (analyse-real-sub analyse exo-type ?values) + "*" (analyse-real-mul analyse exo-type ?values) + "/" (analyse-real-div analyse exo-type ?values) + "%" (analyse-real-rem analyse exo-type ?values) + "=" (analyse-real-eq analyse exo-type ?values) + "<" (analyse-real-lt analyse exo-type ?values) + "encode" (analyse-real-encode analyse exo-type ?values) + "decode" (analyse-real-decode analyse exo-type ?values) + "min-value" (analyse-real-min-value analyse exo-type ?values) + "max-value" (analyse-real-max-value analyse exo-type ?values) + "to-deg" (analyse-real-to-deg analyse exo-type ?values) + ) + + "char" + (case proc + "to-nat" (analyse-char-to-nat analyse exo-type ?values) + ) + + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj new file mode 100644 index 000000000..480cb341a --- /dev/null +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -0,0 +1,1144 @@ +(ns lux.analyser.proc.jvm + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type] + [host :as &host] + [lexer :as &lexer] + [parser :as &parser] + [reader :as &reader]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &&] + [lambda :as &&lambda] + [env :as &&env] + [parser :as &&a-parser]) + [lux.compiler.jvm.base :as &c!base]) + (:import (java.lang.reflect Type TypeVariable))) + +;; [Utils] +(defn ^:private ensure-catching [exceptions*] + "(-> (List Text) (Lux Null))" + (|do [class-loader &/loader] + (fn [state] + (|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*) + catching (->> state + (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev ^Class now] + (or prev + (cond (or (.isAssignableFrom java.lang.RuntimeException now) + (.isAssignableFrom java.lang.Error now)) + nil + + (&/fold (fn [found? ^Class ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + + :else + now))) + nil + exceptions)] + ((&/fail-with-loc (str "[Analyser Error] Unhandled exception: " missing-ex)) + state) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [old-catches (&/get$ &/$catching state) + state* (&/update$ &/$catching (partial &/|++ catches) state)] + (|case (&/run-state body state*) + (&/$Left msg) + (&/$Left msg) + + (&/$Right state** output) + (&/$Right (&/T [(&/set$ &/$catching old-catches state**) + output])))) + )) + +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$HostT payload) + (return payload) + + (&/$VarT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$ExT id) + (return (&/T ["java.lang.Object" (&/|list)])) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) + + (&/$AppT F A) + (|do [type* (&type/apply-type F A)] + (ensure-object type*)) + + _ + (&/fail-with-loc (str "[Analyser Error] Expecting object: " (&type/show-type type))))) + +(defn ^:private as-object [type] + "(-> Type Type)" + (|case type + (&/$HostT class params) + (&/$HostT (&host-type/as-obj class) params) + + _ + type)) + +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$HostT name params) + (&/$HostT (as-otype name) params) + + _ + type)) + +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T [idx real-type]))) + (return (&/T [(+ 2 idx) (&/$BoundT idx)])))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T [idx* (&/$Cons real-type types)])))) + (&/T [1 &/$Nil]) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&/$UnivQ &type/empty-env base-type) + + _ + base-type)) + (&/$HostT class-name type-args) + type-args)) + +;; [Resources] +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$HostT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + +(defn generic-class->simple-class [gclass] + "(-> GenericClass Text)" + (|case gclass + (&/$GenericTypeVar var-name) + "java.lang.Object" + + (&/$GenericWildcard _) + "java.lang.Object" + + (&/$GenericClass name params) + name + + (&/$GenericArray param) + (|case param + (&/$GenericArray _) + (str "[" (generic-class->simple-class param)) + + (&/$GenericClass "boolean" _) + "[Z" + + (&/$GenericClass "byte" _) + "[B" + + (&/$GenericClass "short" _) + "[S" + + (&/$GenericClass "int" _) + "[I" + + (&/$GenericClass "long" _) + "[J" + + (&/$GenericClass "float" _) + "[F" + + (&/$GenericClass "double" _) + "[D" + + (&/$GenericClass "char" _) + "[C" + + (&/$GenericClass name params) + (str "[L" name ";") + + (&/$GenericTypeVar var-name) + "[Ljava.lang.Object;" + + (&/$GenericWildcard _) + "[Ljava.lang.Object;") + )) + +(defn generic-class->type [env gclass] + "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" + (|case gclass + (&/$GenericTypeVar var-name) + (if-let [ex (&/|get var-name env)] + (return ex) + (&/fail-with-loc (str "[Analysis Error] Unknown type var: " var-name))) + + (&/$GenericClass name params) + (case name + "boolean" (return (&/$HostT "java.lang.Boolean" &/$Nil)) + "byte" (return (&/$HostT "java.lang.Byte" &/$Nil)) + "short" (return (&/$HostT "java.lang.Short" &/$Nil)) + "int" (return (&/$HostT "java.lang.Integer" &/$Nil)) + "long" (return (&/$HostT "java.lang.Long" &/$Nil)) + "float" (return (&/$HostT "java.lang.Float" &/$Nil)) + "double" (return (&/$HostT "java.lang.Double" &/$Nil)) + "char" (return (&/$HostT "java.lang.Character" &/$Nil)) + "void" (return &/$UnitT) + ;; else + (|do [=params (&/map% (partial generic-class->type env) params)] + (return (&/$HostT name =params)))) + + (&/$GenericArray param) + (|do [=param (generic-class->type env param)] + (return (&/$HostT &host-type/array-data-tag (&/|list =param)))) + + (&/$GenericWildcard _) + (return (&/$ExQ &/$Nil (&/$BoundT 1))) + )) + +(defn gen-super-env [class-env supers class-decl] + "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" + (|let [[class-name class-vars] class-decl] + (|case (&/|some (fn [super] + (|let [[super-name super-params] super] + (if (= class-name super-name) + (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) + &/$None))) + supers) + (&/$None) + (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) + + (&/$Some vars+gtypes) + (&/map% (fn [var+gtype] + (|do [:let [[var gtype] var+gtype] + =gtype (generic-class->type class-env gtype)] + (return (&/T [var =gtype])))) + vars+gtypes) + ))) + +(defn ^:private make-type-env [type-params] + "(-> (List TypeParam) (Lux (List [Text Type])))" + (&/map% (fn [gvar] + (|do [:let [[gvar-name _] gvar] + ex &type/existential] + (return (&/T [gvar-name ex])))) + type-params)) + +(defn ^:private double-register-gclass? [gclass] + (|case gclass + (&/$GenericClass name _) + (|case name + "long" true + "double" true + _ false) + + _ + false)) + +(defn ^:private method-input-folder [full-env] + (fn [body* input*] + (|do [:let [[iname itype*] input*] + itype (generic-class->type full-env itype*)] + (if (double-register-gclass? itype*) + (&&env/with-local iname itype + (&&env/with-local "" &/$VoidT + body*)) + (&&env/with-local iname itype + body*))))) + +(defn ^:private analyse-method [analyse class-decl class-env all-supers method] + "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" + (|let [[?cname ?cparams] class-decl + class-type (&/$HostT ?cname (&/|map &/|second class-env))] + (|case method + (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + :let [output-type &/$UnitT] + =ctor-args (&/map% (fn [ctor-arg] + (|do [:let [[ca-type ca-term] ctor-arg] + =ca-type (generic-class->type full-env ca-type) + =ca-term (&&/analyse-1 analyse =ca-type ca-term)] + (return (&/T [ca-type =ca-term])))) + ?ctor-args) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) + + (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env (&/|++ class-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [super-env (gen-super-env class-env all-supers ?class-decl) + method-env (make-type-env ?gvars) + :let [full-env (&/|++ super-env method-env)] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&&env/with-local &&/jvm-this class-type + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs))))))] + (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|do [method-env (make-type-env ?gvars) + :let [full-env method-env] + output-type (generic-class->type full-env ?output) + =body (&/with-type-env full-env + (&/with-no-catches + (with-catches (&/|map &host-generics/gclass->class-name ?exceptions) + (&/fold (method-input-folder full-env) + (&&/analyse-1 analyse output-type ?body) + (&/|reverse ?inputs)))))] + (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) + + (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + + (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) + ))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" + (|do [abstract-methods (mandatory-methods supers) + :let [methods-map (&/fold (fn [mmap mentry] + (|case mentry + (&/$ConstructorMethodAnalysis _) + mmap + + (&/$VirtualMethodAnalysis _) + mmap + + (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) + (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) + + (&/$StaticMethodAnalysis _) + mmap + + (&/$AbstractMethodSyntax _) + mmap + + (&/$NativeMethodSyntax _) + mmap + )) + {} + methods) + missing-method (&/fold (fn [missing abs-meth] + (or missing + (|let [[am-name am-inputs] abs-meth] + (if-let [meth-struct (get methods-map am-name)] + (if (some (fn [=inputs] + (and (= (&/|length =inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] + (|let [[iname itype] mi] + (and prev (= (generic-class->simple-class itype) ai)))) + true + =inputs am-inputs))) + meth-struct) + nil + abs-meth) + abs-meth)))) + nil + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (|let [[am-name am-inputs] missing-method] + (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) + +(defn ^:private analyse-field [analyse gtype-env field] + "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) + =value (&&/analyse-1 analyse =gtype ?value)] + (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) + + (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) + (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) + )) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type _?value] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + =value (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) + + ^:private analyse-jvm-d2f "d2f" "java.lang.Double" "java.lang.Float" + ^:private analyse-jvm-d2i "d2i" "java.lang.Double" "java.lang.Integer" + ^:private analyse-jvm-d2l "d2l" "java.lang.Double" "java.lang.Long" + + ^:private analyse-jvm-f2d "f2d" "java.lang.Float" "java.lang.Double" + ^:private analyse-jvm-f2i "f2i" "java.lang.Float" "java.lang.Integer" + ^:private analyse-jvm-f2l "f2l" "java.lang.Float" "java.lang.Long" + + ^:private analyse-jvm-i2b "i2b" "java.lang.Integer" "java.lang.Byte" + ^:private analyse-jvm-i2c "i2c" "java.lang.Integer" "java.lang.Character" + ^:private analyse-jvm-i2d "i2d" "java.lang.Integer" "java.lang.Double" + ^:private analyse-jvm-i2f "i2f" "java.lang.Integer" "java.lang.Float" + ^:private analyse-jvm-i2l "i2l" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-i2s "i2s" "java.lang.Integer" "java.lang.Short" + + ^:private analyse-jvm-l2d "l2d" "java.lang.Long" "java.lang.Double" + ^:private analyse-jvm-l2f "l2f" "java.lang.Long" "java.lang.Float" + ^:private analyse-jvm-l2i "l2i" "java.lang.Long" "java.lang.Integer" + ^:private analyse-jvm-l2s "l2s" "java.lang.Long" "java.lang.Short" + ^:private analyse-jvm-l2b "l2b" "java.lang.Long" "java.lang.Byte" + + ^:private analyse-jvm-c2b "c2b" "java.lang.Character" "java.lang.Byte" + ^:private analyse-jvm-c2s "c2s" "java.lang.Character" "java.lang.Short" + ^:private analyse-jvm-c2i "c2i" "java.lang.Character" "java.lang.Integer" + ^:private analyse-jvm-c2l "c2l" "java.lang.Character" "java.lang.Long" + + ^:private analyse-jvm-s2l "s2l" "java.lang.Short" "java.lang.Long" + + ^:private analyse-jvm-b2l "b2l" "java.lang.Byte" "java.lang.Long" + ) + +(do-template [ ] + (let [output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?value1 (&/$Cons ?value2 (&/$Nil))) ?values] + =value1 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value1) + =value2 (&&/analyse-1 analyse (&/$HostT &/$Nil) ?value2) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) + + ^:private analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" + + ^:private analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ^:private analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" + ) + +(do-template [ ] + (let [input-type (&/$HostT &/$Nil) + output-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) + + ^:private analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" + ^:private analyse-jvm-ieq "ieq" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-ilt "ilt" "java.lang.Integer" "java.lang.Boolean" + ^:private analyse-jvm-igt "igt" "java.lang.Integer" "java.lang.Boolean" + + ^:private analyse-jvm-ceq "ceq" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-clt "clt" "java.lang.Character" "java.lang.Boolean" + ^:private analyse-jvm-cgt "cgt" "java.lang.Character" "java.lang.Boolean" + + ^:private analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" + ^:private analyse-jvm-leq "leq" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-llt "llt" "java.lang.Long" "java.lang.Boolean" + ^:private analyse-jvm-lgt "lgt" "java.lang.Long" "java.lang.Boolean" + + ^:private analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" + ^:private analyse-jvm-feq "feq" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-flt "flt" "java.lang.Float" "java.lang.Boolean" + ^:private analyse-jvm-fgt "fgt" "java.lang.Float" "java.lang.Boolean" + + ^:private analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" + ^:private analyse-jvm-deq "deq" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dlt "dlt" "java.lang.Double" "java.lang.Boolean" + ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" + ) + +(let [length-type &type/Nat + idx-type &type/Nat] + (do-template [ ] + (let [elem-type (&/$HostT &/$Nil) + array-type (&/$HostT &/$Nil)] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) + + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) + ) + + "java.lang.Boolean" "[Z" ^:private analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" + "java.lang.Byte" "[B" ^:private analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" + "java.lang.Short" "[S" ^:private analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" + "java.lang.Integer" "[I" ^:private analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" + "java.lang.Long" "[J" ^:private analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" + "java.lang.Float" "[F" ^:private analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" + "java.lang.Double" "[D" ^:private analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" + "java.lang.Character" "[C" ^:private analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" + )) + +(defn ^:private array-class? [class-name] + (or (= &host-type/array-data-tag class-name) + (case class-name + ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true + ;; else + false))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] + gclass (&reader/with-source "jvm-anewarray" _gclass + &&a-parser/parse-gclass) + gtype-env &/get-type-env + =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) + :let [array-type (&/$HostT &host-type/array-data-tag (&/|list =gclass))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-jvm-aaload [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-jvm-aastore [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-arraylength [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) + ))))) + +(defn ^:private analyse-jvm-null? [analyse exo-type ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null?"]) (&/|list =object) (&/|list))))))) + +(defn ^:private analyse-jvm-null [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &host-type/null-data-tag &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list))))))) + +(defn analyse-jvm-synchronized [analyse exo-type ?values] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values] + =monitor (&&/analyse-1+ analyse ?monitor) + _ (ensure-object (&&/expr-type* =monitor)) + =expr (&&/analyse-1 analyse exo-type ?expr) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "synchronized"]) (&/|list =monitor =expr) (&/|list))))))) + +(defn ^:private analyse-jvm-throw [analyse exo-type ?values] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values] + =ex (&&/analyse-1+ analyse ?ex) + _ (&type/check (&/$HostT "java.lang.Throwable" &/$Nil) (&&/expr-type* =ex)) + [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) + _ (ensure-catching (&/|list throw-class)) + _cursor &/cursor + _ (&type/check exo-type &type/Bottom)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) + +(defn ^:private analyse-jvm-getstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Nil) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + =type (&host-type/instance-param &type/existential &/$Nil gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-getfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Nil)) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader !class! field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) + :let [output-type =type] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) + +(defn ^:private analyse-jvm-putstatic [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons value (&/$Nil)) ?values] + class-loader &/loader + [gvars gtype] (&host/lookup-static-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (&host-type/instance-param &type/existential &/$Nil gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) + +(defn ^:private analyse-jvm-putfield [analyse exo-type class field ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object (&/$Cons value (&/$Nil))) ?values] + class-loader &/loader + =object (&&/analyse-1+ analyse object) + :let [obj-type (&&/expr-type* =object)] + _ (ensure-object obj-type) + [gvars gtype] (&host/lookup-field class-loader !class! field) + :let [gclass (&host-type/gtype->gclass gtype)] + =type (analyse-field-access-helper obj-type gvars gtype) + =value (&&/analyse-1 analyse =type value) + :let [output-type &/$UnitT] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) + +(defn ^:private analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =arg-types (&/map% &type/show-type+ arg-types) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret) + _ (&type/check exo-type (as-otype+ =gret))] + (return (&/T [=gret =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [(&/$VarT _id) $var + gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(let [dummy-type-param (&/$HostT "java.lang.Object" &/$Nil)] + (do-template [ ] + (defn [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [(&/$Cons object args) ?values] + class-loader &/loader + _ (try (assert! (let [=class (Class/forName !class! true class-loader)] + (= (.isInterface =class))) + (if + (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") + (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " class)))) + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T [Void/TYPE &/$Nil &/$Nil &/$Nil &/$Nil])) + (&host/lookup-virtual-method class-loader !class! method classes)) + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$HostT super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) + !class! + sub-class) + sub-params) + :let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Cons (&/T [(.getName g) t]) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" ]) (&/$Cons =object =args) (&/|list class method classes output-type gret))))))) + + ^:private analyse-jvm-invokevirtual "invokevirtual" false + ^:private analyse-jvm-invokespecial "invokespecial" false + ^:private analyse-jvm-invokeinterface "invokeinterface" true + )) + +(defn ^:private analyse-jvm-invokestatic [analyse exo-type class method classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) + _ (ensure-catching exceptions) + :let [gtype-env (&/|table)] + [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T [(make-gtype gtype gtype-vars*) + =args]))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|do [:let [gtype-env* (&/$Cons (&/T [(.getName gtv) $var]) gtype-env)] + [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) + ==gret (&type/clean $var =gret) + ==args (&/map% (partial &&/clean-analysis $var) =args)] + (return (&/T [==gret ==args]))))) + )) + +(defn ^:private analyse-jvm-new [analyse exo-type class classes ?values] + (|do [!class! (&/de-alias-class class) + :let [args ?values] + class-loader &/loader + [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) + _ (ensure-catching exceptions) + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) + +(defn ^:private analyse-jvm-try [analyse exo-type ?values] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values] + =body (with-catches (&/|list "java.lang.Exception") + (&&/analyse-1 analyse exo-type ?body)) + =catch (&&/analyse-1 analyse (&/$LambdaT (&/$HostT "java.lang.Exception" &/$Nil) exo-type) ?catch) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "try"]) (&/|list =body =catch) (&/|list))))))) + +(defn ^:private analyse-jvm-instanceof [analyse exo-type class ?values] + (|do [:let [(&/$Cons object (&/$Nil)) ?values] + =object (&&/analyse-1+ analyse object) + _ (ensure-object (&&/expr-type* =object)) + :let [output-type &type/Bool] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) + +(defn ^:private analyse-jvm-load-class [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS _class-name)] (&/$Nil)) ?values] + ^ClassLoader class-loader &/loader + _ (try (do (.loadClass class-loader _class-name) + (return nil)) + (catch Exception e + (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) + :let [output-type (&/$HostT "java.lang.Class" (&/|list (&/$HostT _class-name (&/|list))))] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) + +(let [length-type &type/Nat + idx-type &type/Nat] + (defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) + array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] + gtype-env &/get-type-env + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) + + (defn ^:private analyse-array-get [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) + + (defn ^:private analyse-array-remove [analyse exo-type ?values] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor + :let [=elem (&&/|meta inner-arr-type _cursor + (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] + _ (&type/check exo-type array-type)] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) + +(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] + (|do [module &/get-module-name + _ (compile-interface interface-decl supers =anns =methods) + :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list))))))) + +(defn ^:private analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] + (&/with-closure + (|do [module &/get-module-name + :let [[?name ?params] class-decl + full-name (str (string/replace module "/" ".") "." ?name) + class-decl* (&/T [full-name ?params]) + all-supers (&/$Cons super-class interfaces)] + class-env (make-type-env ?params) + =fields (&/map% (partial analyse-field analyse class-env) ?fields) + _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) + =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) + _ &/pop-dummy-name + :let [_ (println 'CLASS full-name)] + _cursor &/cursor] + (return (&/|list (&&/|meta &/$UnitT _cursor + (&&/$tuple (&/|list)))))))) + +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [_ (&&/$captured _ _ source)]] + source)) + +(let [default- (&/$ConstructorMethodSyntax (&/T [&/$PublicPM + false + &/$Nil + &/$Nil + &/$Nil + &/$Nil + &/$Nil + (&/$TupleS &/$Nil)])) + captured-slot-class "java.lang.Object" + captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] + (defn ^:private analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] + (&/with-closure + (|do [module &/get-module-name + scope &/get-scope-name + :let [name (->> scope &/|reverse &/|tail &host/location) + class-decl (&/T [name &/$Nil]) + anon-class (str (string/replace module "/" ".") "." name) + anon-class-type (&/$HostT anon-class &/$Nil)] + =ctor-args (&/map% (fn [ctor-arg] + (|let [[arg-type arg-term] ctor-arg] + (|do [=arg-term (&&/analyse-1+ analyse arg-term)] + (return (&/T [arg-type =arg-term]))))) + ctor-args) + _ (->> methods + (&/$Cons default-) + (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) + :let [all-supers (&/$Cons super-class interfaces) + class-env &/$Nil] + =methods (&/map% (partial analyse-method analyse class-decl class-env all-supers) methods) + _ (check-method-completion all-supers =methods) + =captured &&env/captured-vars + :let [=fields (&/|map (fn [^objects idx+capt] + (|let [[idx _] idx+capt] + (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) + &/$PublicPM + &/$FinalSM + &/$Nil + captured-slot-type))) + (&/enumerate =captured))] + :let [sources (&/|map captured-source =captured)] + _ (compile-class class-decl super-class interfaces &/$DefaultIM &/$Nil =fields =methods =captured (&/$Some =ctor-args)) + _ &/pop-dummy-name + _cursor &/cursor] + (return (&/|list (&&/|meta anon-class-type _cursor + (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))) + ))) + )))) + +(defn analyse-host [analyse exo-type compilers proc ?values] + (|let [[_ _ _ compile-class compile-interface] compilers] + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) + ;; else + (->> (&/fail-with-loc (str "[Analyser Error] Unknown JVM procedure: " proc)) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + )) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 1c34926aa..f449a7b3c 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -308,7 +308,7 @@ nil ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) v (recur slot table*)))) @@ -318,7 +318,7 @@ ($Cons (T [slot value]) $Nil) ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) ($Cons (T [slot value]) table*) ($Cons (T [k v]) (|put slot value table*))) )) @@ -329,7 +329,7 @@ table ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) table* ($Cons (T [k v]) (|remove slot table*))))) @@ -339,7 +339,7 @@ table ($Cons [k* v] table*) - (if (.equals ^Object k k*) + (if (= k k*) ($Cons (T [k* (f v)]) table*) ($Cons (T [k* v]) (|update k f table*))))) @@ -465,7 +465,7 @@ false ($Cons [k* _] table*) - (or (.equals ^Object k k*) + (or (= k k*) (|contains? k table*)))) (defn |member? [x xs] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 6aa5d5915..a60afbc23 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -22,8 +22,8 @@ ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - [proc :as &&proc] ) + (lux.compiler.js.proc [common :as &&common]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -99,7 +99,10 @@ (compile-expression ?value-ex) (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args) + (case ?proc-category + ;; "js" ... + ;; common + (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) _ (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) @@ -174,6 +177,7 @@ (&/$Left ?message) (binding [*out* !err!] (do (println (str "Compilation failed:\n" ?message)) - ;; (flush) - ;; (System/exit 1) - ))))))) + (flush) + (System/exit 1) + )) + ))))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index b88d4dc00..62d440d6d 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -40,12 +40,6 @@ (def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) -(defn ^:private _valueOf_ [value] - (reify JSObject - (isFunction [self] true) - (call [self this args] - value))) - (defn ^:private _slice_ [wrap-lux-obj value] (reify JSObject (isFunction [self] true) @@ -58,25 +52,43 @@ (isFunction [self] true) (call [self this args] (&/adt->text obj) - ;; (pr-str this) ))) +(def ^:private i64-mask (dec (bit-shift-left 1 32))) +(defn ^:private to-i64 [value] + (reify JSObject + (getMember [self member] + (condp = member + "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) + "L" (-> value (bit-and i64-mask) int) + ;; else + (assert false (str "to-i64#getMember = " member)))))) + (deftype LuxJsObject [obj] JSObject (isFunction [self] false) (getSlot [self idx] (let [value (aget obj idx)] - (if (instance? lux-obj-class value) - (new LuxJsObject value) - value))) + (cond (instance? lux-obj-class value) + (new LuxJsObject value) + + (instance? java.lang.Long value) + (to-i64 value) + + :else + value))) (getMember [self member] (condp = member - ;; "valueOf" (_valueOf_ obj) "toString" (_toString_ obj) "length" (alength obj) - "slice" (let [wrap-lux-obj #(if (instance? lux-obj-class %) - (new LuxJsObject %) - %)] + "slice" (let [wrap-lux-obj #(cond (instance? lux-obj-class %) + (new LuxJsObject %) + + (instance? java.lang.Long %) + (to-i64 %) + + :else + %)] (_slice_ wrap-lux-obj obj)) ;; else (assert false (str "wrap-lux-obj#getMember = " member))))) @@ -86,6 +98,17 @@ (new LuxJsObject obj) obj)) +(defn ^:private int64? [^ScriptObjectMirror js-object] + (and (.hasMember js-object "H") + (.hasMember js-object "L"))) + +(defn ^:private parse-int64 [^ScriptObjectMirror js-object] + (+ (-> (.getMember js-object "H") + long + (bit-shift-left 32)) + (-> (.getMember js-object "L") + long))) + (defn js-to-lux [js-object] (cond (or (nil? js-object) (instance? java.lang.Boolean js-object) @@ -94,7 +117,7 @@ js-object (instance? java.lang.Number js-object) - (long js-object) + (double js-object) (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) @@ -123,6 +146,9 @@ (.isFunction js-object) js-object + (int64? js-object) + (parse-int64 js-object) + :else (assert false (str "Unknown kind of JS object: " js-object)))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 578eb74f8..a7b1217f0 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -32,9 +32,13 @@ (defn compile-bool [?value] (return (str ?value))) +(def mask-4b (dec (bit-shift-left 1 32))) + (do-template [] (defn [value] - (return (str "(" value "|0)"))) + (let [high (-> value (unsigned-bit-shift-right 32) (bit-and mask-4b)) + low (-> value (bit-and mask-4b))] + (return (str &&rt/LuxRT "." "makeI64" "(" high "," low ")")))) compile-nat compile-int diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc.clj deleted file mode 100644 index 95e6950da..000000000 --- a/luxc/src/lux/compiler/js/proc.clj +++ /dev/null @@ -1,364 +0,0 @@ -(ns lux.compiler.js.proc - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [analyser :as &analyser] - [optimizer :as &o]) - [lux.analyser.base :as &a] - [lux.compiler.js.base :as &&])) - -;; [Resources] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?mask) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-bit-and Opcodes/LAND -;; ^:private compile-bit-or Opcodes/LOR -;; ^:private compile-bit-xor Opcodes/LXOR -;; ) - -;; (defn ^:private compile-bit-count [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") -;; (.visitInsn Opcodes/I2L) -;; &&/wrap-long)]] -;; (return nil))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?shift) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitInsn Opcodes/L2I))] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-bit-shift-left Opcodes/LSHL -;; ^:private compile-bit-shift-right Opcodes/LSHR -;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR -;; ) - -;; (defn ^:private compile-lux-== [compile ?values special-args] -;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?left) -;; _ (compile ?right) -;; :let [$then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) -;; ;; else -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") -;; (.visitLabel $end))]] -;; (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x " " " " =y ")")))) - - ^:private compile-nat-add "+" - ^:private compile-nat-sub "-" - ^:private compile-nat-mul "*" - ^:private compile-nat-div "/" - ^:private compile-nat-rem "%" - ^:private compile-nat-eq "===" - ^:private compile-nat-lt "<" - - ^:private compile-int-add "+" - ^:private compile-int-sub "-" - ^:private compile-int-mul "*" - ^:private compile-int-div "/" - ^:private compile-int-rem "%" - ^:private compile-int-eq "===" - ^:private compile-int-lt "<" - - ^:private compile-deg-add "+" - ^:private compile-deg-sub "-" - ^:private compile-deg-mul "*" - ^:private compile-deg-div "/" - ^:private compile-deg-rem "%" - ^:private compile-deg-eq "===" - ^:private compile-deg-lt "<" - ^:private compile-deg-scale "*" - - ^:private compile-real-add "+" - ^:private compile-real-sub "-" - ^:private compile-real-mul "*" - ^:private compile-real-div "/" - ^:private compile-real-rem "%" - ^:private compile-real-eq "===" - ^:private compile-real-lt "<" - ) - -;; (defn ^:private compile-nat-lt [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long) -;; $then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitLdcInsn (int -1)) -;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitLabel $end))]] -;; (return nil))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Nil) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - -;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long -;; ) - -;; (do-template [ ] -;; (do (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] -;; (return nil))) - -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] -;; (return nil))))) - -;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" -;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" -;; ) - -(defn compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ").toString()")))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-deg-mul "mul_deg" -;; ^:private compile-deg-div "div_deg" -;; ) - -;; (do-template [ ] -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) -;; )]] -;; (return nil)))) - -;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double -;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long -;; ) - -;; (let [widen (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/I2L))) -;; shrink (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/L2I) -;; (.visitInsn Opcodes/I2C)))] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink -;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen -;; )) - -(do-template [] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] - (compile ?x))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x "===" =y ")")))) - -(defn compile-text-append [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str =x ".concat(" =y ")")))) - -(defn compile-proc [compile proc-category proc-name ?values special-args] - (case proc-category - ;; "lux" - ;; (case proc-name - ;; "==" (compile-lux-== compile ?values special-args)) - - "text" - (case proc-name - "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) - - ;; "bit" - ;; (case proc-name - ;; "count" (compile-bit-count compile ?values special-args) - ;; "and" (compile-bit-and compile ?values special-args) - ;; "or" (compile-bit-or compile ?values special-args) - ;; "xor" (compile-bit-xor compile ?values special-args) - ;; "shift-left" (compile-bit-shift-left compile ?values special-args) - ;; "shift-right" (compile-bit-shift-right compile ?values special-args) - ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - - ;; "array" - ;; (case proc-name - ;; "get" (compile-array-get compile ?values special-args)) - - "nat" - (case proc-name - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - ;; "encode" (compile-nat-encode compile ?values special-args) - ;; "decode" (compile-nat-decode compile ?values special-args) - ;; "max-value" (compile-nat-max-value compile ?values special-args) - ;; "min-value" (compile-nat-min-value compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - ;; "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "int" - (case proc-name - "+" (compile-int-add compile ?values special-args) - "-" (compile-int-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "=" (compile-int-eq compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "encode" (compile-int-encode compile ?values special-args) - ;; "decode" (compile-int-decode compile ?values special-args) - ;; "max-value" (compile-int-max-value compile ?values special-args) - ;; "min-value" (compile-int-min-value compile ?values special-args) - "to-nat" (compile-int-to-nat compile ?values special-args) - ) - - "deg" - (case proc-name - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - ;; "encode" (compile-deg-encode compile ?values special-args) - ;; "decode" (compile-deg-decode compile ?values special-args) - ;; "max-value" (compile-deg-max-value compile ?values special-args) - ;; "min-value" (compile-deg-min-value compile ?values special-args) - ;; "to-real" (compile-deg-to-real compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - ) - - "real" - (case proc-name - "+" (compile-real-add compile ?values special-args) - "-" (compile-real-sub compile ?values special-args) - "*" (compile-real-mul compile ?values special-args) - "/" (compile-real-div compile ?values special-args) - "%" (compile-real-rem compile ?values special-args) - "=" (compile-real-eq compile ?values special-args) - "<" (compile-real-lt compile ?values special-args) - ;; "encode" (compile-real-encode compile ?values special-args) - ;; "decode" (compile-real-decode compile ?values special-args) - ;; "max-value" (compile-real-max-value compile ?values special-args) - ;; "min-value" (compile-real-min-value compile ?values special-args) - ;; "to-deg" (compile-real-to-deg compile ?values special-args) - ) - - ;; "char" - ;; (case proc-name - ;; "to-nat" (compile-char-to-nat compile ?values special-args) - ;; ) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj new file mode 100644 index 000000000..7e052892b --- /dev/null +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -0,0 +1,373 @@ +(ns lux.compiler.js.proc.common + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [analyser :as &analyser] + [optimizer :as &o]) + [lux.analyser.base :as &a] + (lux.compiler.js [base :as &&] + [rt :as &&rt]))) + +;; [Resources] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?mask) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-and Opcodes/LAND +;; ^:private compile-bit-or Opcodes/LOR +;; ^:private compile-bit-xor Opcodes/LXOR +;; ) + +;; (defn ^:private compile-bit-count [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") +;; (.visitInsn Opcodes/I2L) +;; &&/wrap-long)]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?input) +;; :let [_ (&&/unwrap-long *writer*)] +;; _ (compile ?shift) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitInsn Opcodes/L2I))] +;; :let [_ (doto *writer* +;; (.visitInsn ) +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-bit-shift-left Opcodes/LSHL +;; ^:private compile-bit-shift-right Opcodes/LSHR +;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR +;; ) + +;; (defn ^:private compile-lux-== [compile ?values special-args] +;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?left) +;; _ (compile ?right) +;; :let [$then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) +;; ;; else +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") +;; (.visitLabel $end))]] +;; (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str &&rt/LuxRT "." "(" =x "," =y ")")))) + + ^:private compile-nat-add "addI64" + ^:private compile-nat-sub "subI64" + ^:private compile-nat-mul "mulI64" + ;; ^:private compile-nat-div "/" + ;; ^:private compile-nat-rem "%" + ^:private compile-nat-eq "eqI64" + ;; ^:private compile-nat-lt "<" + + ^:private compile-int-add "addI64" + ^:private compile-int-sub "subI64" + ^:private compile-int-mul "mulI64" + ;; ^:private compile-int-div "/" + ;; ^:private compile-int-rem "%" + ^:private compile-int-eq "eqI64" + ;; ^:private compile-int-lt "<" + + ^:private compile-deg-add "addI64" + ^:private compile-deg-sub "subI64" + ;; ^:private compile-deg-mul "*" + ;; ^:private compile-deg-div "/" + ^:private compile-deg-rem "subI64" + ^:private compile-deg-eq "eqI64" + ;; ^:private compile-deg-lt "<" + ^:private compile-deg-scale "mulI64" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x " " " " =y ")")))) + + ^:private compile-real-add "+" + ^:private compile-real-sub "-" + ^:private compile-real-mul "*" + ^:private compile-real-div "/" + ^:private compile-real-rem "%" + ^:private compile-real-eq "===" + ^:private compile-real-lt "<" + ) + +;; (defn ^:private compile-nat-lt [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long) +;; $then (new Label) +;; $end (new Label) +;; _ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") +;; (.visitLdcInsn (int -1)) +;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitJumpInsn Opcodes/GOTO $end) +;; (.visitLabel $then) +;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) +;; (.visitLabel $end))]] +;; (return nil))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Nil) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; :let [_ (doto *writer* +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + +;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long +;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long +;; ) + +;; (do-template [ ] +;; (do (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] +;; (return nil))) + +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] +;; (return nil))))) + +;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" +;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" +;; ) + +(defn compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").toString()")))) + +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; _ (compile ?y) +;; :let [_ (doto *writer* +;; &&/unwrap-long)] +;; :let [_ (doto *writer* +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") +;; &&/wrap-long)]] +;; (return nil))) + +;; ^:private compile-deg-mul "mul_deg" +;; ^:private compile-deg-div "div_deg" +;; ) + +;; (do-template [ ] +;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) +;; )]] +;; (return nil)))) + +;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double +;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long +;; ) + +;; (let [widen (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/I2L))) +;; shrink (fn [^MethodVisitor *writer*] +;; (doto *writer* +;; (.visitInsn Opcodes/L2I) +;; (.visitInsn Opcodes/I2C)))] +;; (do-template [ ] +;; (defn [compile ?values special-args] +;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] +;; ^MethodVisitor *writer* &/get-writer +;; _ (compile ?x) +;; :let [_ (doto *writer* +;; +;; +;; )]] +;; (return nil))) + +;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink +;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen +;; )) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x "===" =y ")")))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str =x ".concat(" =y ")")))) + +(defn compile-proc [compile proc-category proc-name ?values special-args] + (case proc-category + ;; "lux" + ;; (case proc-name + ;; "==" (compile-lux-== compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) + + ;; "bit" + ;; (case proc-name + ;; "count" (compile-bit-count compile ?values special-args) + ;; "and" (compile-bit-and compile ?values special-args) + ;; "or" (compile-bit-or compile ?values special-args) + ;; "xor" (compile-bit-xor compile ?values special-args) + ;; "shift-left" (compile-bit-shift-left compile ?values special-args) + ;; "shift-right" (compile-bit-shift-right compile ?values special-args) + ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + ;; "array" + ;; (case proc-name + ;; "get" (compile-array-get compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + ;; "/" (compile-nat-div compile ?values special-args) + ;; "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + ;; "<" (compile-nat-lt compile ?values special-args) + ;; "encode" (compile-nat-encode compile ?values special-args) + ;; "decode" (compile-nat-decode compile ?values special-args) + ;; "max-value" (compile-nat-max-value compile ?values special-args) + ;; "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + ;; "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "int" + (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + ;; "/" (compile-int-div compile ?values special-args) + ;; "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + ;; "<" (compile-int-lt compile ?values special-args) + ;; "encode" (compile-int-encode compile ?values special-args) + ;; "decode" (compile-int-decode compile ?values special-args) + ;; "max-value" (compile-int-max-value compile ?values special-args) + ;; "min-value" (compile-int-min-value compile ?values special-args) + "to-nat" (compile-int-to-nat compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + ;; "*" (compile-deg-mul compile ?values special-args) + ;; "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + ;; "<" (compile-deg-lt compile ?values special-args) + ;; "encode" (compile-deg-encode compile ?values special-args) + ;; "decode" (compile-deg-decode compile ?values special-args) + ;; "max-value" (compile-deg-max-value compile ?values special-args) + ;; "min-value" (compile-deg-min-value compile ?values special-args) + ;; "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "real" + (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + ;; "encode" (compile-real-encode compile ?values special-args) + ;; "decode" (compile-real-decode compile ?values special-args) + ;; "max-value" (compile-real-max-value compile ?values special-args) + ;; "min-value" (compile-real-min-value compile ?values special-args) + ;; "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + ;; "char" + ;; (case proc-name + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ;; ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 3c9186a1e..194248f10 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -936,58 +936,155 @@ ;; (.visitEnd)))] ;; nil))) +(def ^:private i64-methods + {"makeI64" (str "(function makeI64(high,low) {" + "return { H: (high|0), L: (low|0)};" + "})") + "notI64" (str "(function notI64(i64) {" + "return LuxRT.makeI64(~i64.H,~i64.L);" + "})") + "negateI64" (str "(function negateI64(i64) {" + "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.makeI64(0,1));" + "})") + "eqI64" (str "(function eqI64(l,r) {" + "return (l.H === r.H) && (l.L === r.L);" + "})") + "addI64" (str "(function addI64(l,r) {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 + r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 + r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 + r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += l48 + r48;" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "})") + "subI64" (str "(function subI64(l,r) {" + "return LuxRT.addI64(l,LuxRT.negateI64(r));" + "})") + "mulI64" (str "(function mulI64(l,r) {" + "if (l.H < 0) {" + (str "if (r.H < 0) {" + ;; Both are negative + "return mulI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" + "}" + "else {" + ;; Left is negative + "return LuxRT.negateI64(mulI64(LuxRT.negateI64(l),r));" + "}") + "}" + "else if (r.H < 0) {" + ;; Right is negative + "return LuxRT.negateI64(mulI64(l,LuxRT.negateI64(r)));" + "}" + ;; Both are positive + "else {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 * r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 * r00;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x16 += l00 * r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 * r00;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l16 * r16;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l00 * r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "}" + "})") + }) + (def ^:private adt-methods - {:product_getLeft (str "(function product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - :product_getRight (str "(function product_getRight(product,index) {" + {"product_getLeft" (str "(function product_getLeft(product,index) {" "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. + "if(product.length > index_min_length) {" + ;; No need for recursion "return product[index];" "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" - "}" "else {" - ;; Must slice - "return product.slice(index);" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" "}" "})") - :sum_get (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "product_getRight" (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; No match. + "else { return null; }" + "}" + ;; No match. + "else { return null; }" + "})") }) (def LuxRT "LuxRT") (def compile-LuxRT (|do [_ (return nil) - :let [rt-object (str "{" (->> adt-methods + :let [rt-object (str "{" (->> (merge adt-methods + i64-methods) (map (fn [[key val]] - (str (name key) ":" val))) + (str key ":" val))) (interpose ",") (reduce str "")) "}")]] diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index cebe60d9c..d37a061f8 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -254,7 +254,7 @@ (fn [state] ((|do [mappings* (&/map% (fn [binding] (|let [[?id ?type] binding] - (if (.equals ^Object id ?id) + (if (= id ?id) (return binding) (|case ?type (&/$None) @@ -263,7 +263,7 @@ (&/$Some ?type*) (|case ?type* (&/$VarT ?id*) - (if (.equals ^Object id ?id*) + (if (= id ?id*) (return (&/T [?id &/$None])) (return binding)) @@ -287,7 +287,7 @@ (defn clean* [?tid type] (|case type (&/$VarT ?id) - (if (.equals ^Object ?tid ?id) + (if (= ?tid ?id) (|do [? (bound? ?id)] (if ? (deref ?id) @@ -298,7 +298,7 @@ ==type (clean* ?tid =type)] (|case ==type (&/$VarT =id) - (if (.equals ^Object ?tid =id) + (if (= ?tid =id) (|do [_ (unset-var ?id)] (return type)) (|do [_ (reset-var ?id ==type)] @@ -503,13 +503,13 @@ (type= xoutput youtput)) [(&/$VarT xid) (&/$VarT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$BoundT xidx) (&/$BoundT yidx)] (= xidx yidx) [(&/$ExT xid) (&/$ExT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) @@ -652,7 +652,7 @@ (&/with-attempt (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] - (if (.equals ^Object ?eid ?aid) + (if (= ?eid ?aid) (return fixpoints) (|do [ebound (fn [state] (|case ((deref ?eid) state) @@ -834,7 +834,7 @@ (check* class-loader fixpoints* invariant?? eR aR)) [(&/$ExT e!id) (&/$ExT a!id)] - (if (.equals ^Object e!id a!id) + (if (= e!id a!id) (return fixpoints) (check-error "" expected actual)) -- cgit v1.2.3 From 12dcb6e964e0c54f4001413bc62b8bcb526fa9c4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Feb 2017 19:58:26 -0400 Subject: - Now doing common array analysis/compilation. - Now doing common io/log! analysis/compilation. - Now doing common char/to-text analysis/compilation. - Expanded compilation of procedures in JS. - Expanded LuxRT in JS. - Fixed some bugs. --- luxc/src/lux/analyser.clj | 2 +- luxc/src/lux/analyser/proc/common.clj | 80 ++++++++- luxc/src/lux/analyser/proc/jvm.clj | 40 ----- luxc/src/lux/compiler/js/lux.clj | 24 +-- luxc/src/lux/compiler/js/proc/common.clj | 115 ++++++------- luxc/src/lux/compiler/js/rt.clj | 278 +++++++++++++++++++++---------- luxc/src/lux/compiler/jvm/host.clj | 89 +++++++++- luxc/src/lux/type.clj | 3 + 8 files changed, 428 insertions(+), 203 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index f5a200cad..e2aa64590 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -134,7 +134,7 @@ (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type (case ?category - "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + "jvm" (&&jvm/analyse-host analyse exo-type compilers ?proc ?args) ;; "js" ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index f6d1eef8e..3bbc47e88 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -179,17 +179,78 @@ ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + + ^:private analyse-lux-log! &type/Text &/$UnitT ["io" "log!"] ) +(defn ^:private analyse-array-new [analyse exo-type ?values] + (|do [:let [(&/$Cons length (&/$Nil)) ?values] + =length (&&/analyse-1 analyse &type/Nat length) + _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Array (&/$BoundT 1)))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "new"]) (&/|list =length) (&/|list))))))) + +(defn ^:private analyse-array-get [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + =array (&&/analyse-1 analyse (&type/Array $var) array) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type (&/$AppT &type/Maybe $var)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))))) + +(defn ^:private analyse-array-put [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values] + :let [array-type (&type/Array $var)] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse &type/Nat idx) + =elem (&&/analyse-1 analyse $var elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "put"]) (&/|list =array =idx =elem) (&/|list))))))))) + +(defn ^:private analyse-array-remove [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] + :let [array-type (&type/Array $var)] + =array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "remove"]) (&/|list =array =idx) (&/|list))))))))) + +(defn ^:private analyse-array-size [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons array (&/$Nil)) ?values] + =array (&&/analyse-1 analyse (&type/Array $var) array) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" (case proc "==" (analyse-lux-== analyse exo-type ?values)) + "io" + (case proc + "log!" (analyse-lux-log! analyse exo-type ?values)) + "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) @@ -205,13 +266,13 @@ "shift-right" (analyse-bit-shift-right analyse exo-type ?values) "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values)) - ;; "array" - ;; (case proc - ;; "new" (analyse-array-new analyse exo-type ?values) - ;; "get" (analyse-array-get analyse exo-type ?values) - ;; "put" (analyse-jvm-aastore analyse exo-type ?values) - ;; "remove" (analyse-array-remove analyse exo-type ?values) - ;; "size" (analyse-array-size analyse exo-type ?values)) + "array" + (case proc + "new" (analyse-array-new analyse exo-type ?values) + "get" (analyse-array-get analyse exo-type ?values) + "put" (analyse-array-put analyse exo-type ?values) + "remove" (analyse-array-remove analyse exo-type ?values) + "size" (analyse-array-size analyse exo-type ?values)) "nat" (case proc @@ -281,6 +342,7 @@ "char" (case proc + "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj index 480cb341a..72b871686 100644 --- a/luxc/src/lux/analyser/proc/jvm.clj +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -881,46 +881,6 @@ (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) -(let [length-type &type/Nat - idx-type &type/Nat] - (defn ^:private analyse-array-new [analyse exo-type ?values] - (|do [:let [(&/$Cons length (&/$Nil)) ?values] - :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) - array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))] - gtype-env &/get-type-env - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn ^:private analyse-array-get [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list))))))) - - (defn ^:private analyse-array-remove [analyse exo-type ?values] - (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values] - =array (&&/analyse-1+ analyse array) - :let [array-type (&&/expr-type* =array)] - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor - :let [=elem (&&/|meta inner-arr-type _cursor - (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))] - _ (&type/check exo-type array-type)] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - (defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] (|do [module &/get-module-name _ (compile-interface interface-decl supers =anns =methods) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index a7b1217f0..61f21bf55 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -284,15 +284,18 @@ func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) (&/fold str ""))] - =env (&/map% (fn [=captured] - (|case =captured - [_ (&o/$captured ?scope ?captured-id ?source)] - (|do [=source (compile ?source)] - (return (str "var " (captured-name ?captured-id) " = " =source ";"))))) - (&/|vals ?env)) + =env-vars (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (return (captured-name ?captured-id)))) + (&/|vals ?env)) + =env-values (&/map% (fn [=captured] + (|case =captured + [_ (&o/$captured ?scope ?captured-id ?source)] + (compile ?source))) + (&/|vals ?env)) =body (compile ?body)] - (return (str "(function() {" - (->> =env (&/fold str "")) + (return (str "(function(" (->> =env-vars (&/|interpose ",") (&/fold str "")) ") {" "return " (str "(function " function-name "() {" "\"use strict\";" @@ -316,7 +319,7 @@ " };" "}" "})") - ";})()")))) + ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")")))) (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name @@ -345,8 +348,7 @@ _ false) def-type (&a/expr-type* ?body) - _ (&/|log! (str "def-js >>\n" - (string/replace def-js "" "^@")))] + _ (&/|log! (string/replace def-js "" "^@"))] _ (&&/run-js! def-js) def-value (&&/run-js!+ var-name) _ (&/without-repl-closure diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 7e052892b..385761dbe 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -89,26 +89,26 @@ ^:private compile-nat-add "addI64" ^:private compile-nat-sub "subI64" ^:private compile-nat-mul "mulI64" - ;; ^:private compile-nat-div "/" - ;; ^:private compile-nat-rem "%" + ^:private compile-nat-div "divN64" + ^:private compile-nat-rem "remN64" ^:private compile-nat-eq "eqI64" - ;; ^:private compile-nat-lt "<" + ^:private compile-nat-lt "ltN64" ^:private compile-int-add "addI64" ^:private compile-int-sub "subI64" ^:private compile-int-mul "mulI64" - ;; ^:private compile-int-div "/" - ;; ^:private compile-int-rem "%" + ^:private compile-int-div "divI64" + ^:private compile-int-rem "remI64" ^:private compile-int-eq "eqI64" - ;; ^:private compile-int-lt "<" + ^:private compile-int-lt "ltI64" ^:private compile-deg-add "addI64" ^:private compile-deg-sub "subI64" - ;; ^:private compile-deg-mul "*" - ;; ^:private compile-deg-div "/" + ^:private compile-deg-mul "mulD64" + ^:private compile-deg-div "divD64" ^:private compile-deg-rem "subI64" ^:private compile-deg-eq "eqI64" - ;; ^:private compile-deg-lt "<" + ^:private compile-deg-lt "ltD64" ^:private compile-deg-scale "mulI64" ) @@ -128,6 +128,22 @@ ^:private compile-real-lt "<" ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT "." "(" =x ")")))) + + ^:private compile-int-encode "encodeI64" + ^:private compile-nat-encode "encodeN64" + ^:private compile-deg-encode "encodeD64" + ) + +(defn ^:private compile-real-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ")" ".toString()")))) + ;; (defn ^:private compile-nat-lt [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ;; ^MethodVisitor *writer* &/get-writer @@ -166,35 +182,6 @@ ;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long ;; ) -;; (do-template [ ] -;; (do (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] -;; (return nil))) - -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] -;; (return nil))))) - -;; ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" -;; ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" -;; ) - -(defn compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ").toString()")))) - ;; (do-template [ ] ;; (defn [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -261,24 +248,37 @@ ^:private compile-int-to-nat ) -(defn compile-text-eq [compile ?values special-args] +(defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) =y (compile ?y)] (return (str "(" =x "===" =y ")")))) -(defn compile-text-append [compile ?values special-args] +(defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) =y (compile ?y)] (return (str =x ".concat(" =y ")")))) +(defn ^:private compile-char-to-text [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] + (compile ?x))) + +(defn ^:private compile-lux-log! [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + =message (compile ?message)] + (return (str "LuxRT.log(" =message ")")))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category ;; "lux" ;; (case proc-name ;; "==" (compile-lux-== compile ?values special-args)) + "io" + (case proc-name + "log!" (compile-lux-log! compile ?values special-args)) + "text" (case proc-name "=" (compile-text-eq compile ?values special-args) @@ -303,11 +303,11 @@ "+" (compile-nat-add compile ?values special-args) "-" (compile-nat-sub compile ?values special-args) "*" (compile-nat-mul compile ?values special-args) - ;; "/" (compile-nat-div compile ?values special-args) - ;; "%" (compile-nat-rem compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) "=" (compile-nat-eq compile ?values special-args) - ;; "<" (compile-nat-lt compile ?values special-args) - ;; "encode" (compile-nat-encode compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) ;; "decode" (compile-nat-decode compile ?values special-args) ;; "max-value" (compile-nat-max-value compile ?values special-args) ;; "min-value" (compile-nat-min-value compile ?values special-args) @@ -320,11 +320,11 @@ "+" (compile-int-add compile ?values special-args) "-" (compile-int-sub compile ?values special-args) "*" (compile-int-mul compile ?values special-args) - ;; "/" (compile-int-div compile ?values special-args) - ;; "%" (compile-int-rem compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) - ;; "<" (compile-int-lt compile ?values special-args) - ;; "encode" (compile-int-encode compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) ;; "decode" (compile-int-decode compile ?values special-args) ;; "max-value" (compile-int-max-value compile ?values special-args) ;; "min-value" (compile-int-min-value compile ?values special-args) @@ -335,12 +335,12 @@ (case proc-name "+" (compile-deg-add compile ?values special-args) "-" (compile-deg-sub compile ?values special-args) - ;; "*" (compile-deg-mul compile ?values special-args) - ;; "/" (compile-deg-div compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) "%" (compile-deg-rem compile ?values special-args) "=" (compile-deg-eq compile ?values special-args) - ;; "<" (compile-deg-lt compile ?values special-args) - ;; "encode" (compile-deg-encode compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + "encode" (compile-deg-encode compile ?values special-args) ;; "decode" (compile-deg-decode compile ?values special-args) ;; "max-value" (compile-deg-max-value compile ?values special-args) ;; "min-value" (compile-deg-min-value compile ?values special-args) @@ -357,17 +357,18 @@ "%" (compile-real-rem compile ?values special-args) "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) - ;; "encode" (compile-real-encode compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) ;; "decode" (compile-real-decode compile ?values special-args) ;; "max-value" (compile-real-max-value compile ?values special-args) ;; "min-value" (compile-real-min-value compile ?values special-args) ;; "to-deg" (compile-real-to-deg compile ?values special-args) ) - ;; "char" - ;; (case proc-name - ;; "to-nat" (compile-char-to-nat compile ?values special-args) - ;; ) + "char" + (case proc-name + "to-text" (compile-char-to-text compile ?values special-args) + ;; "to-nat" (compile-char-to-nat compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 194248f10..ce5bf5d16 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -765,47 +765,6 @@ ;; (.visitInsn Opcodes/ARETURN) ;; (.visitMaxs 0 0) ;; (.visitEnd))) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 -;; _ (let [$too-big (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) -;; (.visitCode) -;; (.visitLdcInsn "+") -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFLT $too-big) -;; ;; then -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; else -;; (.visitLabel $too-big) -;; ;; Set up parts of the number string... -;; ;; First digits -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/LUSHR) -;; (.visitLdcInsn (long 5)) -;; (.visitInsn Opcodes/LDIV) ;; quot -;; ;; Last digit -;; (.visitInsn Opcodes/DUP2) -;; (.visitLdcInsn (long 10)) -;; (.visitInsn Opcodes/LMUL) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; swap2 -;; (.visitInsn Opcodes/LSUB) ;; quot, rem -;; ;; Conversion to string... -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* -;; (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* -;; (.visitInsn Opcodes/POP) ;; rem*, quot -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* -;; (.visitInsn Opcodes/SWAP) ;; quot*, rem* -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd))) ;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 ;; _ (let [$simple-case (new Label)] ;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) @@ -936,10 +895,57 @@ ;; (.visitEnd)))] ;; nil))) +(def ^:private adt-methods + {"product_getLeft" (str "(function product_getLeft(product,index) {" + "var index_min_length = (index+1);" + "if(product.length > index_min_length) {" + ;; No need for recursion + "return product[index];" + "}" + "else {" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" + "}" + "})") + "product_getRight" (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; No match. + "else { return null; }" + "}" + ;; No match. + "else { return null; }" + "})") + }) + (def ^:private i64-methods {"makeI64" (str "(function makeI64(high,low) {" "return { H: (high|0), L: (low|0)};" "})") + "MIN_VALUE" "{ H: 0x80000000, L: 0}" + "ONE" "{ H: 0, L: 1}" "notI64" (str "(function notI64(i64) {" "return LuxRT.makeI64(~i64.H,~i64.L);" "})") @@ -1030,59 +1036,163 @@ "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" "}" "})") - }) - -(def ^:private adt-methods - {"product_getLeft" (str "(function product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - "product_getRight" (str "(function product_getRight(product,index) {" - "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. - "return product[index];" + "divI64" (str "(function divI64(l,r) {" + (str "if((r.H === 0) && (r.L === 0)) {" + ;; Special case: R = 0 + "throw Error('division by zero');" + "}" + "else if((l.H === 0) && (l.L === 0)) {" + ;; Special case: L = 0 + "return l;" + "}") + (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE)) {" + ;; Special case: L = MIN + (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {" + ;; Special case: L = MIN, R = 1|-1 + "return LuxRT.MIN_VALUE;" "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + ;; Special case: L = R = MIN + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "return LuxRT.ONE;" "}" + ;; Special case: L = MIN "else {" - ;; Must slice - "return product.slice(index);" + "var halfL = LuxRT.shrI64(l,LuxRT.ONE);" + "var approx = LuxRT.shlI64(LuxRT.divI64(halfL,r),LuxRT.ONE);" + (str "if((approx.H === 0) && (approx.L === 0)) {" + (str "if(r.H < 0) {" + "return LuxRT.ONE;" + "}" + "else {" + "return LuxRT.negateI64(LuxRT.ONE);" + "}") + "}" + "else {" + "var rem = LuxRT.subI64(l,LuxRT.mulI64(r,approx));" + "return LuxRT.addI64(approx,LuxRT.divI64(rem,r));" + "}") + "}") + "}" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + ;; Special case: R = MIN + "return LuxRT.makeI64(0,0);" + "}") + ;; Special case: negatives + (str "if(l.H < 0) {" + (str "if(r.H < 0) {" + ;; Both are negative + "return LuxRT.divI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" "}" - "})") - "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "else {" + ;; Only L is negative + "return LuxRT.negateI64(LuxRT.divI64(LuxRT.negateI64(l),r));" + "}") + "}" + "else if(r.H < 0) {" + ;; R is negative + "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));" + "}") + ;; Common case + (str "var res = { H: 0, L: 0};" + "var rem = l;" + (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {" + "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));" + "var log2 = Math.ceil(Math.log(approx) / Math.LN2);" + "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);" + "var approxRes = LuxRT.fromNumberI64(approx);" + "var approxRem = LuxRT.mulI64(approxRes,r);" + (str "while((approxRem.H < 0) || LuxRT.ltI64(rem,approxRem)) {" + "approx -= delta;" + "approxRes = LuxRT.fromNumberI64(approx);" + "approxRem = LuxRT.mulI64(approxRes,r);" + "}") + (str "if((approxRes.H === 0) && (approxRes.L === 0)) {" + "approxRes = LuxRT.ONE;" + "}") + "res = LuxRT.addI64(res,approxRes);" + "rem = LuxRT.subI64(rem,approxRem);" + "}") + "return res;") + "})") + "remI64" (str "(function remI64(l,r) {" + "return LuxRT.subI64(l,LuxRT.mulI64(LuxRT.divI64(l,r),r));" + "})") + "encodeI64" (str "(function encodeI64(input) {" + ;; If input = 0 + (str "if((input.H === 0) && (input.L === 0)) {" + "return '0';" + "}") + ;; If input < 0 + (str "if(input.H < 0) {" + (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE)) {" + "var radix = LuxRT.makeI64(0,10);" + "var div = LuxRT.divI64(input,radix);" + "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);" + "return LuxRT.encodeI64(div).concat(rem.L+'');" + "}") + "}" + "else {" + "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" + "}") + ;; If input > 0 + (str "var chunker = LuxRT.makeI64(0,1000000);" + "var rem = input;" + "var result = '';" + "while (true) {" + (str "var remDiv = LuxRT.divI64(rem,chunker);" + "var chunk = LuxRT.subI64(rem,LuxRT.mulI64(remDiv,chunker));" + "var digits = (chunk.L >>> 0)+'';" + "rem = remDiv;" + (str "if((rem.H === 0) && (rem.L === 0)) {" + "return digits.concat(result);" + "}" + "else {" + (str "while (digits.length < 6) {" + "digits = '0' + digits;" + "}") + "result = '' + digits + result;" + "}")) + "}") + "})") + "ltI64" (str "(function ltI64(l,r) {" + "var ln = l.H < 0;" + "var rn = r.H < 0;" + "if(ln && !rn) { return true; }" + "if(!ln && rn) { return false; }" + "return (LuxRT.subI64(l,r).H < 0);" + "})") + }) + +(def ^:private n64-methods + {"encodeN64" (str "(function encodeN64(input) {" + (str "if(input.H < 0) {" + ;; Too big + "var lastDigit = LuxRT.remI64(input, LuxRT.makeI64(0,10));" + "var minusLastDigit = LuxRT.divI64(input, LuxRT.makeI64(0,10));" + "return '+'.concat(LuxRT.encodeI64(minusLastDigit)).concat(LuxRT.encodeI64(lastDigit));" + "}" + "else {" + ;; Small enough + "return '+'.concat(LuxRT.encodeI64(input));" + "}") + "})") + }) + +(def ^:private io-methods + {"log" (str "(function log(message) {" + "console.log(message);" + (str "return " &&/unit ";") + "})") }) (def LuxRT "LuxRT") (def compile-LuxRT - (|do [_ (return nil) + (|do [_ (&&/run-js! "var console = { log: print };") :let [rt-object (str "{" (->> (merge adt-methods - i64-methods) + i64-methods + n64-methods + io-methods) (map (fn [[key val]] (str key ":" val))) (interpose ",") diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj index 9583c3106..867dd1ff0 100644 --- a/luxc/src/lux/compiler/jvm/host.clj +++ b/luxc/src/lux/compiler/jvm/host.clj @@ -2290,6 +2290,16 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]] + (return nil))) + (defn ^:private compile-array-get [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values ;; (&/$Nil) special-args @@ -2323,6 +2333,54 @@ (.visitLabel $end))]] (return nil))) +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/AASTORE))]] + (return nil))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] @@ -2611,6 +2669,14 @@ ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen )) +(defn ^:private compile-char-to-text [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]] + (return nil))) + (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] @@ -2645,12 +2711,28 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] (return nil))) +(defn compile-io-log! [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V") + (.visitLdcInsn &/unit-tag))]] + (return nil))) + (defn compile-host [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name "==" (compile-lux-== compile ?values special-args)) + "io" + (case proc-name + "log!" (compile-io-log! compile ?values special-args)) + "text" (case proc-name "=" (compile-text-eq compile ?values special-args) @@ -2668,7 +2750,11 @@ "array" (case proc-name - "get" (compile-array-get compile ?values special-args)) + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) "nat" (case proc-name @@ -2733,6 +2819,7 @@ "char" (case proc-name "to-nat" (compile-char-to-nat compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) ) "jvm" diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index d37a061f8..d3805cabc 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -32,6 +32,9 @@ (def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) (def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) +(defn Array [elem-type] + (&/$HostT "#Array" (&/|list elem-type))) + (def Bottom (&/$NamedT (&/T ["lux" "Bottom"]) (&/$UnivQ empty-env -- cgit v1.2.3 From 47ddcadd07234f32d6d4f1411548ccf9665e60c3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Feb 2017 20:36:08 -0400 Subject: - Re-organized JVM-specific compilation a bit. --- luxc/src/lux/compiler/jvm.clj | 21 +- luxc/src/lux/compiler/jvm/host.clj | 2929 ----------------------------- luxc/src/lux/compiler/jvm/proc/common.clj | 588 ++++++ luxc/src/lux/compiler/jvm/proc/host.clj | 1146 +++++++++++ luxc/src/lux/compiler/jvm/rt.clj | 1269 +++++++++++++ 5 files changed, 3016 insertions(+), 2937 deletions(-) delete mode 100644 luxc/src/lux/compiler/jvm/host.clj create mode 100644 luxc/src/lux/compiler/jvm/proc/common.clj create mode 100644 luxc/src/lux/compiler/jvm/proc/host.clj create mode 100644 luxc/src/lux/compiler/jvm/rt.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 5dac1fbbc..d0d3c1bc3 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -23,9 +23,11 @@ (lux.compiler.jvm [base :as &&] [cache :as &&cache] [lux :as &&lux] - [host :as &&host] [case :as &&case] - [lambda :as &&lambda])) + [lambda :as &&lambda] + [rt :as &&rt]) + (lux.compiler.jvm.proc [common :as &&proc-common] + [host :as &&proc-host])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -108,7 +110,9 @@ (compile-expression $begin ?value-ex) (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args) + (if (= "jvm" ?proc-category) + (&&proc-host/compile-proc (partial compile-expression $begin) ?proc-name ?args special-args) + (&&proc-common/compile-proc (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)) _ (assert false (prn-str 'compile-expression (&/adt->text syntax))) @@ -162,8 +166,8 @@ (&/T [(partial &&lux/compile-def compile-expression) (partial &&lux/compile-program compile-expression*) (fn [macro args state] (-> macro (.apply args) (.apply state))) - (partial &&host/compile-jvm-class compile-expression*) - &&host/compile-jvm-interface]))) + (partial &&proc-host/compile-jvm-class compile-expression*) + &&proc-host/compile-jvm-interface]))) (let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) +datum-sig+ "Ljava/lang/Object;"] @@ -190,8 +194,8 @@ .visitEnd) (.visitSource file-name nil))] _ (if (= "lux" name) - (|do [_ &&host/compile-Function-class - _ &&host/compile-LuxRT-class] + (|do [_ &&rt/compile-Function-class + _ &&rt/compile-LuxRT-class] (return nil)) (return nil))] (fn [state] @@ -255,4 +259,5 @@ (binding [*out* !err!] (do (println (str "Compilation failed:\n" ?message)) (flush) - (System/exit 1))))))) + (System/exit 1))) + )))) diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj deleted file mode 100644 index 867dd1ff0..000000000 --- a/luxc/src/lux/compiler/jvm/host.clj +++ /dev/null @@ -1,2929 +0,0 @@ -(ns lux.compiler.jvm.host - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - [lux.compiler.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "") - -(let [class+method+sig {"boolean" &&/unwrap-boolean - "byte" &&/unwrap-byte - "short" &&/unwrap-short - "int" &&/unwrap-int - "long" &&/unwrap-long - "float" &&/unwrap-float - "double" &&/unwrap-double - "char" &&/unwrap-char}] - (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] - (if-let [unwrap (get class+method+sig class-name)] - (doto *writer* - unwrap) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) - -(let [boolean-class "java.lang.Boolean" - byte-class "java.lang.Byte" - short-class "java.lang.Short" - int-class "java.lang.Integer" - long-class "java.lang.Long" - float-class "java.lang.Float" - double-class "java.lang.Double" - char-class "java.lang.Character"] - (defn prepare-return! [^MethodVisitor *writer* *type*] - (|case *type* - (&/$UnitT) - (.visitLdcInsn *writer* &/unit-tag) - - (&/$HostT "boolean" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) - - (&/$HostT "byte" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) - - (&/$HostT "short" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) - - (&/$HostT "int" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) - - (&/$HostT "long" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) - - (&/$HostT "float" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) - - (&/$HostT "double" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) - - (&/$HostT "char" (&/$Nil)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) - - (&/$HostT _ _) - nil - - (&/$NamedT ?name ?type) - (prepare-return! *writer* ?type) - - (&/$ExT _) - nil - - _ - (assert false (str 'prepare-return! " " (&type/show-type *type*)))) - *writer*)) - -;; [Resources] -(defn ^:private compile-annotation [writer ann] - (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) - nil) - -(defn ^:private compile-field [^ClassWriter writer field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|let [=field (.visitField writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) - ?name - (&host-generics/gclass->simple-signature ?gclass) - (&host-generics/gclass->signature ?gclass) nil)] - (do (&/|map (partial compile-annotation =field) ?anns) - (.visitEnd =field) - nil)) - - (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) - (|let [=field (.visitField writer - (+ (&host/privacy-modifier->flag =privacy-modifier) - (&host/state-modifier->flag =state-modifier)) - =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) nil)] - (do (&/|map (partial compile-annotation =field) =anns) - (.visitEnd =field) - nil)) - )) - -(defn ^:private compile-method-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$Nil)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$Nil)) - (doto writer - &&/unwrap-boolean - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$Nil)) - (doto writer - &&/unwrap-byte - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$Nil)) - (doto writer - &&/unwrap-short - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$Nil)) - (doto writer - &&/unwrap-int - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$Nil)) - (doto writer - &&/unwrap-long - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$Nil)) - (doto writer - &&/unwrap-float - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$Nil)) - (doto writer - &&/unwrap-double - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$Nil)) - (doto writer - &&/unwrap-char - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass _class-name (&/$Nil)) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) - (.visitInsn Opcodes/ARETURN)) - - _ - (.visitInsn writer Opcodes/ARETURN))) - -(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] - "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" - (|case input - [_ (&/$GenericClass name params)] - (case name - "boolean" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-boolean - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) - "byte" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-byte - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) - "short" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-short - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) - "int" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-int - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) - "long" (do (doto method-visitor - (.visitVarInsn Opcodes/LLOAD idx) - &&/wrap-long - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) - "float" (do (doto method-visitor - (.visitVarInsn Opcodes/FLOAD idx) - &&/wrap-float - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) - "double" (do (doto method-visitor - (.visitVarInsn Opcodes/DLOAD idx) - &&/wrap-double - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) - "char" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-char - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) - ;; else - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) - - [_ gclass] - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) - )) - -(defn ^:private prepare-method-inputs [idx inputs method-visitor] - "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" - (|case inputs - (&/$Nil) - (return &/$Nil) - - (&/$Cons input inputs*) - (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] - (|do [:let [[_idx _outputs] idx+outputs] - [idx* output] (prepare-method-input _idx input method-visitor)] - (return (&/T [idx* (&/$Cons output _outputs)])))) - (&/T [idx &/$Nil]) - inputs)] - (return (&/list-join (&/|reverse outputs*)))) - )) - -(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] - (|case method-def - (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|let [?output (&/$GenericClass "void" (&/|list)) - =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0)) - init-method - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [[super-class-name super-class-params] ?super-class - init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) - init-sig (str "(" init-types ")" "V") - _ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] - _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) - :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if =final? Opcodes/ACC_FINAL 0) - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0) - Opcodes/ACC_STATIC) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 0 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_ABSTRACT - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - - (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - )) - -(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) - =method (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - _ (&/|map (partial compile-annotation =method) =anns) - _ (.visitEnd =method)] - nil)) - -(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] - (case type - "boolean" (doto writer - &&/unwrap-boolean) - "byte" (doto writer - &&/unwrap-byte) - "short" (doto writer - &&/unwrap-short) - "int" (doto writer - &&/unwrap-int) - "long" (doto writer - &&/unwrap-long) - "float" (doto writer - &&/unwrap-float) - "double" (doto writer - &&/unwrap-double) - "char" (doto writer - &&/unwrap-char) - ;; else - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) - -(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") - -return "V"] - (defn ^:private anon-class--signature [env] - (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" - -return)) - - (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] - (|let [[super-class-name super-class-params] super-class - init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] - (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0))] - _ (&/map% (fn [type+term] - (|let [[type term] type+term] - (|do [_ (compile term) - :let [_ (prepare-ctor-arg =method type)]] - (return nil)))) - ctor-args) - :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq env)]))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ) - -(defn ^:private constant-inits [fields] - "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" - (&/fold &/|++ - &/$Nil - (&/|map (fn [field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (&/|list (&/T [?name ?gclass ?value])) - - (&/$VariableFieldSyntax _) - (&/|list) - )) - fields))) - -(declare compile-jvm-putstatic) -(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] - (|do [module &/get-module-name - [file-name line column] &/cursor - :let [[?name ?params] class-decl - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) - full-name (str module "/" ?name) - super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - (&host/inheritance-modifier->flag ?inheritance-modifier)) - full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =class) ?anns) - _ (&/|map (partial compile-field =class) - ?fields)] - _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) - _ (|case ??ctor-args - (&/$Some ctor-args) - (add-anon-class- =class compile full-name ?super-class env ctor-args) - - _ - (return nil)) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode))] - _ (&/map% (fn [ftriple] - (|let [[fname fgclass fvalue] ftriple] - (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) - (constant-inits ?fields)) - :let [_ (doto =method - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) - -(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] - (|do [:let [[interface-name interface-vars] interface-decl] - module &/get-module-name - [file-name _ _] &/cursor - :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) - (str module "/" interface-name) - (if (= "" interface-signature) nil interface-signature) - "java/lang/Object" - (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =interface) ?anns) - _ (do (&/|map (partial compile-method-decl =interface) ?methods) - (.visitEnd =interface))]] - (&&/save-class! interface-name (.toByteArray =interface)))) - -(def compile-Function-class - (|do [_ (return nil) - :let [super-class "java/lang/Object" - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - Opcodes/ACC_ABSTRACT - ;; Opcodes/ACC_INTERFACE - ) - &&/function-class nil super-class (into-array String [])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) - (doto (.visitEnd)))) - =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (dotimes [arity* &&/num-apply-variants] - (let [arity (inc arity*)] - (if (= 1 arity) - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) - (.visitEnd)) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) - (.visitCode) - (-> (.visitVarInsn Opcodes/ALOAD idx) - (->> (dotimes [idx arity]))) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD arity) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))))]] - (&&/save-class! (second (string/split &&/function-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] - (|let [_ (let [$begin (new Label) - $not-rec (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size - (.visitInsn Opcodes/ISUB) ;; sub-index - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple - (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size - (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem - (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-rec) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $is-last (new Label) - $must-copy (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index - (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem - (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; - ;; Must recurse - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitInsn Opcodes/DUP) ;; tuple, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size - (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem - (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem - (.visitInsn Opcodes/AALOAD) ;; tuple-tail - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple - (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size - (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* - (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* - (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail - (.visitVarInsn Opcodes/ASTORE 0) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $must-copy) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $is-last) ;; tuple-size, index-last-elem - (.visitInsn Opcodes/POP2) ;; - (.visitVarInsn Opcodes/ALOAD 0) ;; tuple - (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index - (.visitInsn Opcodes/AALOAD) ;; elem - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $just-return (new Label) - $then (new Label) - $further (new Label) - $not-right (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - (.visitVarInsn Opcodes/ILOAD 1) ;; tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum - (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' - &&/unwrap-int ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag - (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag - (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $then) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? - (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) - (.visitJumpInsn Opcodes/GOTO $further) - (.visitLabel $just-return) - (.visitInsn Opcodes/POP2) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitLabel $further) ;; tag, sum-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum - (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? - (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? - (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/ISUB) ;; sub-tag - (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum - (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx - (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag - (.visitVarInsn Opcodes/ISTORE 1) ;; - (.visitJumpInsn Opcodes/GOTO $begin) - (.visitLabel $not-right) ;; tag, sum-tag - (.visitInsn Opcodes/POP2) - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; I commented-out some parts because a null-check was - ;; done to ensure variants were never created with null - ;; values (this would interfere later with - ;; pattern-matching). - ;; Since Lux itself doesn't have null values as part of - ;; the language, the burden of ensuring non-nulls was - ;; shifted to library code dealing with host-interop, to - ;; ensure variant-making was as fast as possible. - ;; The null-checking code was left as comments in case I - ;; ever change my mind. - _ (let [;; $is-null (new Label) - ] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - ;; (.visitVarInsn Opcodes/ALOAD 2) - ;; (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 3)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ILOAD 0) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - ;; (.visitLabel $is-null) - ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - ;; (.visitInsn Opcodes/DUP) - ;; (.visitLdcInsn "Can't create variant for null pointer") - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - ;; (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)))] - nil)) - -(defn ^:private low-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. - (.visitLdcInsn (int -1)) - (.visitInsn Opcodes/I2L) - ;; Then do a bitwise and. - (.visitInsn Opcodes/LAND) - )) - -(defn ^:private high-4b [^MethodVisitor =method] - (doto =method - ;; Assume there is a long at the top of the stack... - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - )) - -(defn ^:private swap2 [^MethodVisitor =method] - (doto =method - ;; X2, Y2 - (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X2 - )) - -(defn ^:private swap2x1 [^MethodVisitor =method] - (doto =method - ;; X1, Y2 - (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X1 - )) - -(defn ^:private bit-set-64? [^MethodVisitor =method] - (doto =method - ;; L, I - (.visitLdcInsn (long 1)) ;; L, I, L - (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L - (.visitInsn Opcodes/POP2) ;; L, L, I - (.visitInsn Opcodes/LSHL) ;; L, L - (.visitInsn Opcodes/LAND) ;; L - (.visitLdcInsn (long 0)) ;; L, L - (.visitInsn Opcodes/LCMP) ;; I - )) - -(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] - (|let [deg-bits 64 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) - ;; Based on: http://stackoverflow.com/a/31629280/6823464 - (.visitCode) - ;; Bottom part - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Middle part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) low-4b - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) - ;; Join middle and bottom - (.visitInsn Opcodes/LADD) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - ;; Top part - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LMUL) - ;; Join top with rest - (.visitInsn Opcodes/LADD) - ;; Return - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) - (.visitCode) - ;; Based on: http://stackoverflow.com/a/8510587/6823464 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) high-4b - (.visitInsn Opcodes/LDIV) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) - (.visitCode) - ;; Translate high bytes - (.visitVarInsn Opcodes/LLOAD 0) high-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Translate low bytes - (.visitVarInsn Opcodes/LLOAD 0) low-4b - (.visitInsn Opcodes/L2D) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DDIV) - ;; Combine and return - (.visitInsn Opcodes/DADD) - (.visitInsn Opcodes/DRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) - (.visitCode) - ;; Drop any excess - (.visitVarInsn Opcodes/DLOAD 0) - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - ;; Shift upper half, but retain remaining decimals - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Make a copy, so the lower half can be extracted - (.visitInsn Opcodes/DUP2) - ;; Get that lower half - (.visitLdcInsn (double 1.0)) - (.visitInsn Opcodes/DREM) - (.visitLdcInsn (double (Math/pow 2 32))) - (.visitInsn Opcodes/DMUL) - ;; Turn it into a deg - (.visitInsn Opcodes/D2L) - ;; Turn the upper half into deg too - swap2 - (.visitInsn Opcodes/D2L) - ;; Combine both pieces - (.visitInsn Opcodes/LADD) - ;; FINISH - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int 0)) ;; {carry} - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} - (.visitLdcInsn (int 5)) - (.visitInsn Opcodes/IMUL) - (.visitInsn Opcodes/IADD) ;; {next-raw-digit} - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 0) - swap2x1 - (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IDIV) ;; {next-carry} - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 0) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) - (.visitCode) - ;; Initialize digits array. - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} - (.visitInsn Opcodes/DUP) - (.visitVarInsn Opcodes/ILOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 - (.visitVarInsn Opcodes/ASTORE 1) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitVarInsn Opcodes/ILOAD 0) ;; {times} - (.visitLabel $loop-start) - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - ;; {times} - (.visitVarInsn Opcodes/ILOAD 0) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} - (.visitVarInsn Opcodes/ASTORE 1) ;; {times} - ;; Decrement index - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - ;; {times-1} - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits - (.visitLdcInsn (int 0)) ;; {carry} - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - ;; {carry} - (.visitVarInsn Opcodes/ALOAD 3) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; {carry} - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {carry, dL} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} - (.visitInsn Opcodes/IADD) - (.visitInsn Opcodes/IADD) ;; {raw-next-digit} - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} - (.visitVarInsn Opcodes/ALOAD 3) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} - (.visitLdcInsn (int 10)) - (.visitInsn Opcodes/IDIV) ;; {next-carry} - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn "") ;; {text} - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitInsn Opcodes/BALOAD) ;; {text, digit} - (.visitLdcInsn (int 10)) ;; {text, digit, radix} - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $not-set (new Label) - $next-iteration (new Label) - $normal-path (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - ;; A quick corner-case to handle. - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $normal-path) - (.visitLdcInsn ".0") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $normal-path) - ;; Normal case - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 3) ;; digits - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - ;; Prepare text to return. - (.visitVarInsn Opcodes/ALOAD 3) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") - (.visitLdcInsn ".") - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - ;; Trim unnecessary 0s at the end... - (.visitLdcInsn "0*$") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - bit-set-64? - (.visitJumpInsn Opcodes/IFEQ $next-iteration) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") - (.visitVarInsn Opcodes/ALOAD 3) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") - (.visitVarInsn Opcodes/ASTORE 3) - (.visitJumpInsn Opcodes/GOTO $next-iteration) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $next-iteration) - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $not-set (new Label) - $next-iteration (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn (int deg-bits)) - (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) - (.visitVarInsn Opcodes/ASTORE 2) ;; digits - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") - ;; Set digit - (.visitVarInsn Opcodes/ALOAD 2) - (.visitVarInsn Opcodes/ILOAD 1) - swap2x1 - (.visitInsn Opcodes/BASTORE) - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $is-less-than (new Label) - $is-equal (new Label)] - ;; [B0 <= [B1 - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) - (.visitCode) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int deg-bits)) - (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) - (.visitLdcInsn false) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {D0} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {D0, D1} - (.visitInsn Opcodes/DUP2) - (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) - (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) - ;; Is greater than... - (.visitLdcInsn false) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $is-less-than) - (.visitInsn Opcodes/POP2) - (.visitLdcInsn true) - (.visitInsn Opcodes/IRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $is-equal) - ;; Increment index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label) - $simple-sub (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) - (.visitCode) - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} - (.visitInsn Opcodes/BALOAD) - (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} - (.visitInsn Opcodes/DUP2) - (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Since $0 < $1 - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) ;; $1 - $0 - (.visitLdcInsn (byte 10)) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) - ;; Prepare to iterate... - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Subtract 1 from next digit - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $simple-sub) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 2) - swap2x1 - (.visitInsn Opcodes/BASTORE) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop-start (new Label) - $do-a-round (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) - (.visitCode) - (.visitLdcInsn (int (dec deg-bits))) - (.visitVarInsn Opcodes/ISTORE 2) ;; Index - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitJumpInsn Opcodes/IFGE $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} - (.visitVarInsn Opcodes/ALOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} - (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") - (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits - ;; Decrement index - (.visitVarInsn Opcodes/ILOAD 2) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitVarInsn Opcodes/ISTORE 2) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - $loop-start (new Label) - $do-a-round (new Label) - $skip-power (new Label) - $iterate (new Label) - $bad-format (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - ;; Check prefix - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn ".") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") - (.visitJumpInsn Opcodes/IFEQ $bad-format) - ;; Check if size is valid - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . - (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) - ;; Initialization - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitLabel $from) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") - (.visitLabel $to) - (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ISTORE 1) ;; Index - (.visitLdcInsn (long 0)) - (.visitVarInsn Opcodes/LSTORE 2) ;; Output - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $loop-start) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int deg-bits)) - (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) - (.visitVarInsn Opcodes/LLOAD 2) - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $do-a-round) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") - (.visitInsn Opcodes/DUP2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") - (.visitJumpInsn Opcodes/IFNE $skip-power) - ;; Subtract power - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") - (.visitVarInsn Opcodes/ASTORE 0) - ;; Set bit on output - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 1)) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int (dec deg-bits))) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) - (.visitInsn Opcodes/LSHL) - (.visitInsn Opcodes/LOR) - (.visitVarInsn Opcodes/LSTORE 2) - (.visitJumpInsn Opcodes/GOTO $iterate) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $skip-power) - (.visitInsn Opcodes/POP2) - ;; (.visitJumpInsn Opcodes/GOTO $iterate) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $iterate) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD) - (.visitVarInsn Opcodes/ISTORE 1) - ;; Iterate - (.visitJumpInsn Opcodes/GOTO $loop-start) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $handler) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $bad-format) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))] - nil)) - -(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] - (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - - $good-start (new Label) - $short-enough (new Label) - $bad-digit (new Label) - $out-of-bounds (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - ;; Remove the + at the beginning... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitLdcInsn "+") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFNE $good-start) - ;; Doesn't start with + - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Starts with + - (.visitLabel $good-start) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... - ;; Begin parsing processs - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 18)) - (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) - ;; Too long - ;; Get prefix... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... - ;; Get last digit... - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") - (.visitLdcInsn (int 10)) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") - ;; Test last digit... - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFLT $bad-digit) - ;; Good digit... - ;; Stack: prefix::L, prefix::L, last-digit::I - (.visitInsn Opcodes/I2L) - ;; Build the result... - swap2 - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L - (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L - swap2 ;; Stack: result::L, result::L, prefix::L - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $out-of-bounds) - ;; Within bounds - ;; Stack: result::L - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Out of bounds - (.visitLabel $out-of-bounds) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; Bad digit... - (.visitLabel $bad-digit) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - ;; 18 chars or less - (.visitLabel $short-enough) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $to) - (.visitLabel $handler) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 - _ (let [$too-big (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitLdcInsn "+") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $too-big) - ;; then - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - ;; else - (.visitLabel $too-big) - ;; Set up parts of the number string... - ;; First digits - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/LUSHR) - (.visitLdcInsn (long 5)) - (.visitInsn Opcodes/LDIV) ;; quot - ;; Last digit - (.visitInsn Opcodes/DUP2) - (.visitLdcInsn (long 10)) - (.visitInsn Opcodes/LMUL) - (.visitVarInsn Opcodes/LLOAD 0) - swap2 - (.visitInsn Opcodes/LSUB) ;; quot, rem - ;; Conversion to string... - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* - (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* - (.visitInsn Opcodes/POP) ;; rem*, quot - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* - (.visitInsn Opcodes/SWAP) ;; quot*, rem* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 - _ (let [$simple-case (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGE $simple-case) - ;; else - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitLdcInsn (int 32)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LSHL) - (.visitLdcInsn (int 32)) - (.visitInsn Opcodes/LUSHR) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - ;; then - (.visitLabel $simple-case) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") - (.visitInsn Opcodes/LADD) - (.visitInsn Opcodes/LCMP) - (.visitInsn Opcodes/IRETURN) - (.visitMaxs 0 0) - (.visitEnd)) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 - _ (let [$case-1 (new Label) - $0 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLT $case-1) - ;; Test #2 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFGT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LDIV) - (.visitInsn Opcodes/LRETURN) - ;; Case #1 - (.visitLabel $case-1) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $0) - ;; 1 - (.visitLdcInsn (long 1)) - (.visitInsn Opcodes/LRETURN) - ;; 0 - (.visitLabel $0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LRETURN) - (.visitMaxs 0 0) - (.visitEnd))) - ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 - _ (let [$test-2 (new Label) - $case-2 (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) - (.visitCode) - ;; Test #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitLdcInsn (long 0)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFLE $test-2) - ;; Case #1 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitInsn Opcodes/LREM) - (.visitInsn Opcodes/LRETURN) - ;; Test #2 - (.visitLabel $test-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitJumpInsn Opcodes/IFLT $case-2) - ;; Case #3 - (.visitVarInsn Opcodes/LLOAD 0) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitVarInsn Opcodes/LLOAD 2) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") - (.visitInsn Opcodes/LRETURN) - ;; Case #2 - (.visitLabel $case-2) - (.visitVarInsn Opcodes/LLOAD 0) - (.visitInsn Opcodes/LRETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitMaxs 0 0) - (.visitEnd)))] - nil))) - -(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] - (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn "Invalid expression for pattern-matching.") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(def compile-LuxRT-class - (|do [_ (return nil) - :let [full-name &&/lux-utils-class - super-class (&host-generics/->bytecode-class-name "java.lang.Object") - tag-sig (&host-generics/->type-signature "java.lang.String") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - full-name nil super-class (into-array String []))) - =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) - (.visitEnd)) - =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitLdcInsn "LOG: ") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I - (.visitLdcInsn "") ;; I? - (.visitVarInsn Opcodes/ALOAD 0) ;; I?O - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn "_") - (.visitLdcInsn "") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto =class - (compile-LuxRT-pm-methods) - (compile-LuxRT-adt-methods) - (compile-LuxRT-nat-methods) - (compile-LuxRT-deg-methods))]] - (&&/save-class! (second (string/split &&/lux-utils-class #"/")) - (.toByteArray (doto =class .visitEnd))))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float - ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int - ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long - - ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double - ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int - ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long - - ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte - ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char - ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double - ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float - ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long - ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short - - ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double - ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float - ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int - - ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte - ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short - ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int - ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long - - ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long - - ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long - ) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short - ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - )] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - _ (doto *writer* - (.visitInsn ) - ())]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int - ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int - ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int - ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int - ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float - ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float - - ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int - ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int - ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int - - ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char - ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char - ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn ) - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-int-eq Opcodes/LCMP 0 &&/unwrap-long - ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long - - ^:private compile-real-eq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double - - ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long - ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long - ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long - - ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float - ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float - ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float - - ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double - ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (doto *writer* - - (.visitInsn ))]] - (return nil))) - ) - - Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean - Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte - Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short - Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int - Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long - Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float - Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double - Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char - ) - -(defn ^:private compile-jvm-anewarray [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values - (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] - (return nil))) - -(defn ^:private compile-jvm-aaload [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] - (return nil))) - -(defn ^:private compile-jvm-aastore [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-jvm-arraylength [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-jvm-null [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Nil) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - -(defn ^:private compile-jvm-null? [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IFNULL $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(defn compile-jvm-synchronized [compile ?values special-args] - (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?monitor) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/MONITORENTER))] - _ (compile ?expr) - :let [_ (doto *writer* - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/MONITOREXIT))]] - (return nil))) - -(defn ^:private compile-jvm-throw [compile ?values special-args] - (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?ex) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) - -(defn ^:private compile-jvm-getstatic [compile ?values special-args] - (|do [:let [;; (&/$Nil) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-getfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-putstatic [compile ?values special-args] - (|do [:let [(&/$Cons ?value (&/$Nil)) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [=input-sig (&host-type/gclass->sig input-gclass) - _ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-putfield [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values - (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - _ (compile ?value) - =input-sig (&host/->java-sig ?input-type) - :let [_ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-invokestatic [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?object ?args) ?values - (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] - :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (compile ?object) - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - - ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL - ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL - ) - -(defn ^:private compile-jvm-new [compile ?values special-args] - (|do [:let [?args ?values - (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") - class* (&host-generics/->bytecode-class-name ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [class-name+arg] - (|do [:let [[class-name arg] class-name+arg] - ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (&/zip2 ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] - (return nil))) - -(defn ^:private compile-jvm-try [compile ?values special-args] - (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - :let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - :let [_ (doto *writer* - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from))] - _ (compile ?body) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler))] - _ (compile ?catch) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private compile-jvm-load-class [compile ?values special-args] - (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn _class-name) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-instanceof [compile ?values special-args] - (|do [:let [(&/$Cons object (&/$Nil)) ?values - (&/$Cons class (&/$Nil)) special-args] - :let [class* (&host-generics/->bytecode-class-name class)] - ^MethodVisitor *writer* &/get-writer - _ (compile object) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/INSTANCEOF class*) - (&&/wrap-boolean))]] - (return nil))) - -(defn ^:private compile-array-new [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]] - (return nil))) - -(defn ^:private compile-array-get [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - array-type (&host/->java-sig (&a/expr-type* ?array)) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)] - :let [$is-null (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $is-null) - (.visitLdcInsn (int 1)) - (.visitLdcInsn "") - (.visitInsn Opcodes/DUP2_X1) ;; I?2I? - (.visitInsn Opcodes/POP2) ;; I?2 - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $is-null) - (.visitInsn Opcodes/POP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/ACONST_NULL) - (.visitLdcInsn &/unit-tag) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - -(defn ^:private compile-array-put [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP))] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-array-remove [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP))] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL) - (.visitInsn Opcodes/AASTORE))]] - (return nil))) - -(defn ^:private compile-array-size [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?mask) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-and Opcodes/LAND - ^:private compile-bit-or Opcodes/LOR - ^:private compile-bit-xor Opcodes/LXOR - ) - -(defn ^:private compile-bit-count [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?shift) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-bit-shift-left Opcodes/LSHL - ^:private compile-bit-shift-right Opcodes/LSHR - ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR - ) - -(defn ^:private compile-lux-== [compile ?values special-args] - (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?left) - _ (compile ?right) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IF_ACMPEQ $then) - ;; else - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - _ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-int-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-int-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-nat-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-nat-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-nat-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long - - ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long - - ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - (&&/wrap-long))]] - (return nil))) - - ^:private compile-nat-div "div_nat" - ^:private compile-nat-rem "rem_nat" - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-nat-eq 0 - - ^:private compile-deg-eq 0 - ^:private compile-deg-lt -1 - ) - -(defn ^:private compile-nat-lt [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Nil) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - - )]] - (return nil))) - - ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - - ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] - (return nil))) - - (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] - (return nil))))) - - ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" - ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" - ) - -(defn ^:private compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] - (return nil))) - -(defn ^:private compile-real-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-double - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long)] - _ (compile ?y) - :let [_ (doto *writer* - &&/unwrap-long)] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") - &&/wrap-long)]] - (return nil))) - - ^:private compile-deg-mul "mul_deg" - ^:private compile-deg-div "div_deg" - ) - -(do-template [ ] - (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) - )]] - (return nil)))) - - ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double - ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long - ) - -(let [widen (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/I2L))) - shrink (fn [^MethodVisitor *writer*] - (doto *writer* - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/I2C)))] - (do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - - - )]] - (return nil))) - - ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink - ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen - )) - -(defn ^:private compile-char-to-text [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]] - (return nil))) - -(do-template [] - (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x)] - (return nil))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - _ (compile ?y) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (&&/wrap-boolean))]] - (return nil))) - -(defn compile-text-append [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] - (return nil))) - -(defn compile-io-log! [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V") - (.visitLdcInsn &/unit-tag))]] - (return nil))) - -(defn compile-host [compile proc-category proc-name ?values special-args] - (case proc-category - "lux" - (case proc-name - "==" (compile-lux-== compile ?values special-args)) - - "io" - (case proc-name - "log!" (compile-io-log! compile ?values special-args)) - - "text" - (case proc-name - "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) - - "bit" - (case proc-name - "count" (compile-bit-count compile ?values special-args) - "and" (compile-bit-and compile ?values special-args) - "or" (compile-bit-or compile ?values special-args) - "xor" (compile-bit-xor compile ?values special-args) - "shift-left" (compile-bit-shift-left compile ?values special-args) - "shift-right" (compile-bit-shift-right compile ?values special-args) - "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - - "array" - (case proc-name - "new" (compile-array-new compile ?values special-args) - "get" (compile-array-get compile ?values special-args) - "put" (compile-array-put compile ?values special-args) - "remove" (compile-array-remove compile ?values special-args) - "size" (compile-array-size compile ?values special-args)) - - "nat" - (case proc-name - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - "encode" (compile-nat-encode compile ?values special-args) - "decode" (compile-nat-decode compile ?values special-args) - "max-value" (compile-nat-max-value compile ?values special-args) - "min-value" (compile-nat-min-value compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "deg" - (case proc-name - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - "encode" (compile-deg-encode compile ?values special-args) - "decode" (compile-deg-decode compile ?values special-args) - "max-value" (compile-deg-max-value compile ?values special-args) - "min-value" (compile-deg-min-value compile ?values special-args) - "to-real" (compile-deg-to-real compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - ) - - "int" - (case proc-name - "+" (compile-int-add compile ?values special-args) - "-" (compile-int-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "=" (compile-int-eq compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "to-nat" (compile-int-to-nat compile ?values special-args) - "encode" (compile-int-encode compile ?values special-args) - ) - - "real" - (case proc-name - "+" (compile-real-add compile ?values special-args) - "-" (compile-real-sub compile ?values special-args) - "*" (compile-real-mul compile ?values special-args) - "/" (compile-real-div compile ?values special-args) - "%" (compile-real-rem compile ?values special-args) - "=" (compile-real-eq compile ?values special-args) - "<" (compile-real-lt compile ?values special-args) - "encode" (compile-real-encode compile ?values special-args) - "to-deg" (compile-real-to-deg compile ?values special-args) - ) - - "char" - (case proc-name - "to-nat" (compile-char-to-nat compile ?values special-args) - "to-text" (compile-char-to-text compile ?values special-args) - ) - - "jvm" - (case proc-name - "synchronized" (compile-jvm-synchronized compile ?values special-args) - "load-class" (compile-jvm-load-class compile ?values special-args) - "instanceof" (compile-jvm-instanceof compile ?values special-args) - "try" (compile-jvm-try compile ?values special-args) - "new" (compile-jvm-new compile ?values special-args) - "invokestatic" (compile-jvm-invokestatic compile ?values special-args) - "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) - "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) - "invokespecial" (compile-jvm-invokespecial compile ?values special-args) - "getstatic" (compile-jvm-getstatic compile ?values special-args) - "getfield" (compile-jvm-getfield compile ?values special-args) - "putstatic" (compile-jvm-putstatic compile ?values special-args) - "putfield" (compile-jvm-putfield compile ?values special-args) - "throw" (compile-jvm-throw compile ?values special-args) - "null?" (compile-jvm-null? compile ?values special-args) - "null" (compile-jvm-null compile ?values special-args) - "anewarray" (compile-jvm-anewarray compile ?values special-args) - "aaload" (compile-jvm-aaload compile ?values special-args) - "aastore" (compile-jvm-aastore compile ?values special-args) - "arraylength" (compile-jvm-arraylength compile ?values special-args) - "znewarray" (compile-jvm-znewarray compile ?values special-args) - "bnewarray" (compile-jvm-bnewarray compile ?values special-args) - "snewarray" (compile-jvm-snewarray compile ?values special-args) - "inewarray" (compile-jvm-inewarray compile ?values special-args) - "lnewarray" (compile-jvm-lnewarray compile ?values special-args) - "fnewarray" (compile-jvm-fnewarray compile ?values special-args) - "dnewarray" (compile-jvm-dnewarray compile ?values special-args) - "cnewarray" (compile-jvm-cnewarray compile ?values special-args) - "iadd" (compile-jvm-iadd compile ?values special-args) - "isub" (compile-jvm-isub compile ?values special-args) - "imul" (compile-jvm-imul compile ?values special-args) - "idiv" (compile-jvm-idiv compile ?values special-args) - "irem" (compile-jvm-irem compile ?values special-args) - "ieq" (compile-jvm-ieq compile ?values special-args) - "ilt" (compile-jvm-ilt compile ?values special-args) - "igt" (compile-jvm-igt compile ?values special-args) - "ceq" (compile-jvm-ceq compile ?values special-args) - "clt" (compile-jvm-clt compile ?values special-args) - "cgt" (compile-jvm-cgt compile ?values special-args) - "ladd" (compile-jvm-ladd compile ?values special-args) - "lsub" (compile-jvm-lsub compile ?values special-args) - "lmul" (compile-jvm-lmul compile ?values special-args) - "ldiv" (compile-jvm-ldiv compile ?values special-args) - "lrem" (compile-jvm-lrem compile ?values special-args) - "leq" (compile-jvm-leq compile ?values special-args) - "llt" (compile-jvm-llt compile ?values special-args) - "lgt" (compile-jvm-lgt compile ?values special-args) - "fadd" (compile-jvm-fadd compile ?values special-args) - "fsub" (compile-jvm-fsub compile ?values special-args) - "fmul" (compile-jvm-fmul compile ?values special-args) - "fdiv" (compile-jvm-fdiv compile ?values special-args) - "frem" (compile-jvm-frem compile ?values special-args) - "feq" (compile-jvm-feq compile ?values special-args) - "flt" (compile-jvm-flt compile ?values special-args) - "fgt" (compile-jvm-fgt compile ?values special-args) - "dadd" (compile-jvm-dadd compile ?values special-args) - "dsub" (compile-jvm-dsub compile ?values special-args) - "dmul" (compile-jvm-dmul compile ?values special-args) - "ddiv" (compile-jvm-ddiv compile ?values special-args) - "drem" (compile-jvm-drem compile ?values special-args) - "deq" (compile-jvm-deq compile ?values special-args) - "dlt" (compile-jvm-dlt compile ?values special-args) - "dgt" (compile-jvm-dgt compile ?values special-args) - "iand" (compile-jvm-iand compile ?values special-args) - "ior" (compile-jvm-ior compile ?values special-args) - "ixor" (compile-jvm-ixor compile ?values special-args) - "ishl" (compile-jvm-ishl compile ?values special-args) - "ishr" (compile-jvm-ishr compile ?values special-args) - "iushr" (compile-jvm-iushr compile ?values special-args) - "land" (compile-jvm-land compile ?values special-args) - "lor" (compile-jvm-lor compile ?values special-args) - "lxor" (compile-jvm-lxor compile ?values special-args) - "lshl" (compile-jvm-lshl compile ?values special-args) - "lshr" (compile-jvm-lshr compile ?values special-args) - "lushr" (compile-jvm-lushr compile ?values special-args) - "d2f" (compile-jvm-d2f compile ?values special-args) - "d2i" (compile-jvm-d2i compile ?values special-args) - "d2l" (compile-jvm-d2l compile ?values special-args) - "f2d" (compile-jvm-f2d compile ?values special-args) - "f2i" (compile-jvm-f2i compile ?values special-args) - "f2l" (compile-jvm-f2l compile ?values special-args) - "i2b" (compile-jvm-i2b compile ?values special-args) - "i2c" (compile-jvm-i2c compile ?values special-args) - "i2d" (compile-jvm-i2d compile ?values special-args) - "i2f" (compile-jvm-i2f compile ?values special-args) - "i2l" (compile-jvm-i2l compile ?values special-args) - "i2s" (compile-jvm-i2s compile ?values special-args) - "l2d" (compile-jvm-l2d compile ?values special-args) - "l2f" (compile-jvm-l2f compile ?values special-args) - "l2i" (compile-jvm-l2i compile ?values special-args) - "l2s" (compile-jvm-l2s compile ?values special-args) - "l2b" (compile-jvm-l2b compile ?values special-args) - "c2b" (compile-jvm-c2b compile ?values special-args) - "c2s" (compile-jvm-c2s compile ?values special-args) - "c2i" (compile-jvm-c2i compile ?values special-args) - "c2l" (compile-jvm-c2l compile ?values special-args) - "s2l" (compile-jvm-s2l compile ?values special-args) - "b2l" (compile-jvm-b2l compile ?values special-args) - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj new file mode 100644 index 000000000..4ed8134fd --- /dev/null +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -0,0 +1,588 @@ +(ns lux.compiler.jvm.proc.common + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Resources] +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]] + (return nil))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)] + :let [$is-null (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 1)) + (.visitLdcInsn "") + (.visitInsn Opcodes/DUP2_X1) ;; I?2I? + (.visitInsn Opcodes/POP2) ;; I?2 + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $is-null) + (.visitInsn Opcodes/POP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/ACONST_NULL) + (.visitLdcInsn &/unit-tag) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/AASTORE))]] + (return nil))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?mask) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-and Opcodes/LAND + ^:private compile-bit-or Opcodes/LOR + ^:private compile-bit-xor Opcodes/LXOR + ) + +(defn ^:private compile-bit-count [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (&&/unwrap-long *writer*)] + _ (compile ?shift) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + &&/wrap-long)]] + (return nil))) + + ^:private compile-bit-shift-left Opcodes/LSHL + ^:private compile-bit-shift-right Opcodes/LSHR + ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR + ) + +(defn ^:private compile-lux-== [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?left) + _ (compile ?right) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IF_ACMPEQ $then) + ;; else + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + _ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-int-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-int-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-nat-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long + + ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + (&&/wrap-long))]] + (return nil))) + + ^:private compile-nat-div "div_nat" + ^:private compile-nat-rem "rem_nat" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn ) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-int-eq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long + + ^:private compile-real-eq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-nat-eq 0 + + ^:private compile-deg-eq 0 + ^:private compile-deg-lt -1 + ) + +(defn ^:private compile-nat-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + + )]] + (return nil))) + + ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(J)Ljava/lang/String;"))]] + (return nil))) + + (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)Ljava/lang/Object;"))]] + (return nil))))) + + ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat" + ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" + ) + +(defn ^:private compile-int-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-real-encode [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + &&/unwrap-long)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-deg-mul "mul_deg" + ^:private compile-deg-div "div_deg" + ) + +(do-template [ ] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) + )]] + (return nil)))) + + ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double + ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long + ) + +(let [widen (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/I2L))) + shrink (fn [^MethodVisitor *writer*] + (doto *writer* + (.visitInsn Opcodes/L2I) + (.visitInsn Opcodes/I2C)))] + (do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + + )]] + (return nil))) + + ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink + ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen + )) + +(defn ^:private compile-char-to-text [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]] + (return nil))) + +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x)] + (return nil))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + +(defn compile-text-eq [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + _ (compile ?y) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-text-append [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] + (return nil))) + +(defn compile-io-log! [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V") + (.visitLdcInsn &/unit-tag))]] + (return nil))) + +(defn compile-proc [compile proc-category proc-name ?values special-args] + (case proc-category + "lux" + (case proc-name + "==" (compile-lux-== compile ?values special-args)) + + "io" + (case proc-name + "log!" (compile-io-log! compile ?values special-args)) + + "text" + (case proc-name + "=" (compile-text-eq compile ?values special-args) + "append" (compile-text-append compile ?values special-args)) + + "bit" + (case proc-name + "count" (compile-bit-count compile ?values special-args) + "and" (compile-bit-and compile ?values special-args) + "or" (compile-bit-or compile ?values special-args) + "xor" (compile-bit-xor compile ?values special-args) + "shift-left" (compile-bit-shift-left compile ?values special-args) + "shift-right" (compile-bit-shift-right compile ?values special-args) + "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + + "array" + (case proc-name + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) + + "nat" + (case proc-name + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) + "encode" (compile-nat-encode compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) + ) + + "deg" + (case proc-name + "+" (compile-deg-add compile ?values special-args) + "-" (compile-deg-sub compile ?values special-args) + "*" (compile-deg-mul compile ?values special-args) + "/" (compile-deg-div compile ?values special-args) + "%" (compile-deg-rem compile ?values special-args) + "=" (compile-deg-eq compile ?values special-args) + "<" (compile-deg-lt compile ?values special-args) + "encode" (compile-deg-encode compile ?values special-args) + "decode" (compile-deg-decode compile ?values special-args) + "max-value" (compile-deg-max-value compile ?values special-args) + "min-value" (compile-deg-min-value compile ?values special-args) + "to-real" (compile-deg-to-real compile ?values special-args) + "scale" (compile-deg-scale compile ?values special-args) + ) + + "int" + (case proc-name + "+" (compile-int-add compile ?values special-args) + "-" (compile-int-sub compile ?values special-args) + "*" (compile-int-mul compile ?values special-args) + "/" (compile-int-div compile ?values special-args) + "%" (compile-int-rem compile ?values special-args) + "=" (compile-int-eq compile ?values special-args) + "<" (compile-int-lt compile ?values special-args) + "to-nat" (compile-int-to-nat compile ?values special-args) + "encode" (compile-int-encode compile ?values special-args) + ) + + "real" + (case proc-name + "+" (compile-real-add compile ?values special-args) + "-" (compile-real-sub compile ?values special-args) + "*" (compile-real-mul compile ?values special-args) + "/" (compile-real-div compile ?values special-args) + "%" (compile-real-rem compile ?values special-args) + "=" (compile-real-eq compile ?values special-args) + "<" (compile-real-lt compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) + "to-deg" (compile-real-to-deg compile ?values special-args) + ) + + "char" + (case proc-name + "to-nat" (compile-char-to-nat compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) + ) + + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj new file mode 100644 index 000000000..0e299f123 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/proc/host.clj @@ -0,0 +1,1146 @@ +(ns lux.compiler.jvm.proc.host + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "") + +(let [class+method+sig {"boolean" &&/unwrap-boolean + "byte" &&/unwrap-byte + "short" &&/unwrap-short + "int" &&/unwrap-int + "long" &&/unwrap-long + "float" &&/unwrap-float + "double" &&/unwrap-double + "char" &&/unwrap-char}] + (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] + (if-let [unwrap (get class+method+sig class-name)] + (doto *writer* + unwrap) + (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) + +(let [boolean-class "java.lang.Boolean" + byte-class "java.lang.Byte" + short-class "java.lang.Short" + int-class "java.lang.Integer" + long-class "java.lang.Long" + float-class "java.lang.Float" + double-class "java.lang.Double" + char-class "java.lang.Character"] + (defn prepare-return! [^MethodVisitor *writer* *type*] + (|case *type* + (&/$UnitT) + (.visitLdcInsn *writer* &/unit-tag) + + (&/$HostT "boolean" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) + + (&/$HostT "byte" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) + + (&/$HostT "short" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) + + (&/$HostT "int" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) + + (&/$HostT "long" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) + + (&/$HostT "float" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) + + (&/$HostT "double" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) + + (&/$HostT "char" (&/$Nil)) + (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) + + (&/$HostT _ _) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + (&/$ExT _) + nil + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) + *writer*)) + +;; [Resources] +(defn ^:private compile-annotation [writer ann] + (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [^ClassWriter writer field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (|let [=field (.visitField writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) + ?name + (&host-generics/gclass->simple-signature ?gclass) + (&host-generics/gclass->signature ?gclass) nil)] + (do (&/|map (partial compile-annotation =field) ?anns) + (.visitEnd =field) + nil)) + + (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) + (|let [=field (.visitField writer + (+ (&host/privacy-modifier->flag =privacy-modifier) + (&host/state-modifier->flag =state-modifier)) + =name + (&host-generics/gclass->simple-signature =type) + (&host-generics/gclass->signature =type) nil)] + (do (&/|map (partial compile-annotation =field) =anns) + (.visitEnd =field) + nil)) + )) + +(defn ^:private compile-method-return [^MethodVisitor writer output] + (|case output + (&/$GenericClass "void" (&/$Nil)) + (.visitInsn writer Opcodes/RETURN) + + (&/$GenericClass "boolean" (&/$Nil)) + (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "byte" (&/$Nil)) + (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "short" (&/$Nil)) + (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "int" (&/$Nil)) + (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass "long" (&/$Nil)) + (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + + (&/$GenericClass "float" (&/$Nil)) + (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + + (&/$GenericClass "double" (&/$Nil)) + (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + + (&/$GenericClass "char" (&/$Nil)) + (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + + (&/$GenericClass _class-name (&/$Nil)) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) + (.visitInsn Opcodes/ARETURN)) + + _ + (.visitInsn writer Opcodes/ARETURN))) + +(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor] + "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" + (|case input + [_ (&/$GenericClass name params)] + (case name + "boolean" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-boolean + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) + "byte" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-byte + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) + "short" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-short + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) + "int" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-int + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) + "long" (do (doto method-visitor + (.visitVarInsn Opcodes/LLOAD idx) + &&/wrap-long + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) + "float" (do (doto method-visitor + (.visitVarInsn Opcodes/FLOAD idx) + &&/wrap-float + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) + "double" (do (doto method-visitor + (.visitVarInsn Opcodes/DLOAD idx) + &&/wrap-double + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) + "char" (do (doto method-visitor + (.visitVarInsn Opcodes/ILOAD idx) + &&/wrap-char + (.visitVarInsn Opcodes/ASTORE idx)) + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) + ;; else + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) + + [_ gclass] + (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) + )) + +(defn ^:private prepare-method-inputs [idx inputs method-visitor] + "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" + (|case inputs + (&/$Nil) + (return &/$Nil) + + (&/$Cons input inputs*) + (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] + (|do [:let [[_idx _outputs] idx+outputs] + [idx* output] (prepare-method-input _idx input method-visitor)] + (return (&/T [idx* (&/$Cons output _outputs)])))) + (&/T [idx &/$Nil]) + inputs)] + (return (&/list-join (&/|reverse outputs*)))) + )) + +(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] + (|case method-def + (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) + (|let [?output (&/$GenericClass "void" (&/|list)) + =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0)) + init-method + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [[super-class-name super-class-params] ?super-class + init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) + init-sig (str "(" init-types ")" "V") + _ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] + _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) + :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if =final? Opcodes/ACC_FINAL 0) + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC + (if ?strict Opcodes/ACC_STRICT 0)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 1 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ (&host/privacy-modifier->flag ?privacy-modifier) + (if ?strict Opcodes/ACC_STRICT 0) + Opcodes/ACC_STATIC) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitCode =method)] + =input-tags (prepare-method-inputs 0 ?inputs =method) + _ (compile (&o/optimize ?body)) + :let [_ (doto =method + (compile-method-return ?output) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))) + + (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_ABSTRACT + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + + (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) + (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] + (&/with-writer (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE + (&host/privacy-modifier->flag ?privacy-modifier)) + ?name + simple-signature + generic-signature + (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + (|do [^MethodVisitor =method &/get-writer + :let [_ (&/|map (partial compile-annotation =method) ?anns) + _ (.visitEnd =method)]] + (return nil)))) + )) + +(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] + (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl + [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) + =method (.visitMethod class-writer + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) + =name + simple-signature + generic-signature + (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) + _ (&/|map (partial compile-annotation =method) =anns) + _ (.visitEnd =method)] + nil)) + +(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] + (case type + "boolean" (doto writer + &&/unwrap-boolean) + "byte" (doto writer + &&/unwrap-byte) + "short" (doto writer + &&/unwrap-short) + "int" (doto writer + &&/unwrap-int) + "long" (doto writer + &&/unwrap-long) + "float" (doto writer + &&/unwrap-float) + "double" (doto writer + &&/unwrap-double) + "char" (doto writer + &&/unwrap-char) + ;; else + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) + +(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") + -return "V"] + (defn ^:private anon-class--signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + -return)) + + (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] + (|let [[super-class-name super-class-params] super-class + init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))] + (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0))] + _ (&/map% (fn [type+term] + (|let [[type term] type+term] + (|do [_ (compile term) + :let [_ (prepare-ctor-arg =method type)]] + (return nil)))) + ctor-args) + :let [_ (doto =method + (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [_ (&o/$captured _ ?captured-id ?source)]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + ) + +(defn ^:private constant-inits [fields] + "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" + (&/fold &/|++ + &/$Nil + (&/|map (fn [field] + (|case field + (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) + (&/|list (&/T [?name ?gclass ?value])) + + (&/$VariableFieldSyntax _) + (&/|list) + )) + fields))) + +(declare compile-jvm-putstatic) +(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] + (|do [module &/get-module-name + [file-name line column] &/cursor + :let [[?name ?params] class-decl + class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces)) + full-name (str module "/" ?name) + super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + (&host/inheritance-modifier->flag ?inheritance-modifier)) + full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) + ?fields)] + _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) + _ (|case ??ctor-args + (&/$Some ctor-args) + (add-anon-class- =class compile full-name ?super-class env ctor-args) + + _ + (return nil)) + _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (doto =method + (.visitCode))] + _ (&/map% (fn [ftriple] + (|let [[fname fgclass fvalue] ftriple] + (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) + (constant-inits ?fields)) + :let [_ (doto =method + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil)))] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) + +(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] + (|do [:let [[interface-name interface-vars] interface-decl] + module &/get-module-name + [file-name _ _] &/cursor + :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) + =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) + (str module "/" interface-name) + (if (= "" interface-signature) nil interface-signature) + "java/lang/Object" + (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) + (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) + (.visitEnd =interface))]] + (&&/save-class! interface-name (.toByteArray =interface)))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(do-template [ ] + (defn [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float + ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int + ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long + + ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double + ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int + ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long + + ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte + ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char + ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double + ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float + ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long + ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short + + ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double + ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float + ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int + + ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte + ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short + ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int + ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long + + ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long + + ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long + ) + +(do-template [ ] + (defn [compile _?value special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) _?value] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short + ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + )] + :let [_ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int + ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + _ (doto *writer* + (.visitInsn ) + ())]] + (return nil))) + + ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int + ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int + ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int + ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int + ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int + + ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long + ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long + ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long + + ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float + ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float + ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float + + ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int + ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int + ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int + + ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char + ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn ) + (.visitLdcInsn (int )) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long + ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long + ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long + + ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float + ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float + ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float + + ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double + ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double + ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double + ) + +(do-template [ ] + (do (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitInsn ) + )]] + (return nil))) + + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (doto *writer* + + (.visitInsn ))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn ^:private compile-jvm-anewarray [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values + (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?length) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] + (return nil))) + +(defn ^:private compile-jvm-aaload [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] + (return nil))) + +(defn ^:private compile-jvm-aastore [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + +(defn ^:private compile-jvm-arraylength [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + array-type (&host/->java-sig (&a/expr-type* ?array)) + _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] + :let [_ (doto *writer* + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-jvm-null [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Nil) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + +(defn ^:private compile-jvm-null? [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn Opcodes/IFNULL $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + +(defn compile-jvm-synchronized [compile ?values special-args] + (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?monitor) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/MONITORENTER))] + _ (compile ?expr) + :let [_ (doto *writer* + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/MONITOREXIT))]] + (return nil))) + +(defn ^:private compile-jvm-throw [compile ?values special-args] + (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + _ (compile ?ex) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) + +(defn ^:private compile-jvm-getstatic [compile ?values special-args] + (|do [:let [;; (&/$Nil) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-getfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + =output-type (&host/->java-sig ?output-type) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST class*) + (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-putstatic [compile ?values special-args] + (|do [:let [(&/$Cons ?value (&/$Nil)) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args] + ^MethodVisitor *writer* &/get-writer + _ (compile ?value) + :let [=input-sig (&host-type/gclass->sig input-gclass) + _ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-putfield [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values + (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args] + :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + _ (compile ?object) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] + _ (compile ?value) + =input-sig (&host/->java-sig ?input-type) + :let [_ (doto *writer* + (prepare-arg! (&host-generics/gclass->class-name input-gclass)) + (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) + (.visitInsn Opcodes/ACONST_NULL))]] + (return nil))) + +(defn ^:private compile-jvm-invokestatic [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?object ?args) ?values + (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args] + :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] + ^MethodVisitor *writer* &/get-writer + :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] + _ (compile ?object) + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] + _ (&/map2% (fn [class-name arg] + (|do [ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + ?classes ?args) + :let [_ (doto *writer* + (.visitMethodInsn ?class* ?method method-sig) + (prepare-return! ?output-type))]] + (return nil))) + + ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL + ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE + ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL + ) + +(defn ^:private compile-jvm-new [compile ?values special-args] + (|do [:let [?args ?values + (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") + class* (&host-generics/->bytecode-class-name ?class) + _ (doto *writer* + (.visitTypeInsn Opcodes/NEW class*) + (.visitInsn Opcodes/DUP))] + _ (&/map% (fn [class-name+arg] + (|do [:let [[class-name arg] class-name+arg] + ret (compile arg) + :let [_ (prepare-arg! *writer* class-name)]] + (return ret))) + (&/zip2 ?classes ?args)) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] + (return nil))) + +(defn ^:private compile-jvm-try [compile ?values special-args] + (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + ^MethodVisitor *writer* &/get-writer + :let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + :let [_ (doto *writer* + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from))] + _ (compile ?body) + :let [_ (doto *writer* + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler))] + _ (compile ?catch) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] + :let [_ (.visitLabel *writer* $end)]] + (return nil))) + +(defn ^:private compile-jvm-load-class [compile ?values special-args] + (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn _class-name) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") + (prepare-return! ?output-type))]] + (return nil))) + +(defn ^:private compile-jvm-instanceof [compile ?values special-args] + (|do [:let [(&/$Cons object (&/$Nil)) ?values + (&/$Cons class (&/$Nil)) special-args] + :let [class* (&host-generics/->bytecode-class-name class)] + ^MethodVisitor *writer* &/get-writer + _ (compile object) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/INSTANCEOF class*) + (&&/wrap-boolean))]] + (return nil))) + +(defn compile-proc [compile proc-name ?values special-args] + "jvm" + (case proc-name + "synchronized" (compile-jvm-synchronized compile ?values special-args) + "load-class" (compile-jvm-load-class compile ?values special-args) + "instanceof" (compile-jvm-instanceof compile ?values special-args) + "try" (compile-jvm-try compile ?values special-args) + "new" (compile-jvm-new compile ?values special-args) + "invokestatic" (compile-jvm-invokestatic compile ?values special-args) + "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) + "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) + "invokespecial" (compile-jvm-invokespecial compile ?values special-args) + "getstatic" (compile-jvm-getstatic compile ?values special-args) + "getfield" (compile-jvm-getfield compile ?values special-args) + "putstatic" (compile-jvm-putstatic compile ?values special-args) + "putfield" (compile-jvm-putfield compile ?values special-args) + "throw" (compile-jvm-throw compile ?values special-args) + "null?" (compile-jvm-null? compile ?values special-args) + "null" (compile-jvm-null compile ?values special-args) + "anewarray" (compile-jvm-anewarray compile ?values special-args) + "aaload" (compile-jvm-aaload compile ?values special-args) + "aastore" (compile-jvm-aastore compile ?values special-args) + "arraylength" (compile-jvm-arraylength compile ?values special-args) + "znewarray" (compile-jvm-znewarray compile ?values special-args) + "bnewarray" (compile-jvm-bnewarray compile ?values special-args) + "snewarray" (compile-jvm-snewarray compile ?values special-args) + "inewarray" (compile-jvm-inewarray compile ?values special-args) + "lnewarray" (compile-jvm-lnewarray compile ?values special-args) + "fnewarray" (compile-jvm-fnewarray compile ?values special-args) + "dnewarray" (compile-jvm-dnewarray compile ?values special-args) + "cnewarray" (compile-jvm-cnewarray compile ?values special-args) + "iadd" (compile-jvm-iadd compile ?values special-args) + "isub" (compile-jvm-isub compile ?values special-args) + "imul" (compile-jvm-imul compile ?values special-args) + "idiv" (compile-jvm-idiv compile ?values special-args) + "irem" (compile-jvm-irem compile ?values special-args) + "ieq" (compile-jvm-ieq compile ?values special-args) + "ilt" (compile-jvm-ilt compile ?values special-args) + "igt" (compile-jvm-igt compile ?values special-args) + "ceq" (compile-jvm-ceq compile ?values special-args) + "clt" (compile-jvm-clt compile ?values special-args) + "cgt" (compile-jvm-cgt compile ?values special-args) + "ladd" (compile-jvm-ladd compile ?values special-args) + "lsub" (compile-jvm-lsub compile ?values special-args) + "lmul" (compile-jvm-lmul compile ?values special-args) + "ldiv" (compile-jvm-ldiv compile ?values special-args) + "lrem" (compile-jvm-lrem compile ?values special-args) + "leq" (compile-jvm-leq compile ?values special-args) + "llt" (compile-jvm-llt compile ?values special-args) + "lgt" (compile-jvm-lgt compile ?values special-args) + "fadd" (compile-jvm-fadd compile ?values special-args) + "fsub" (compile-jvm-fsub compile ?values special-args) + "fmul" (compile-jvm-fmul compile ?values special-args) + "fdiv" (compile-jvm-fdiv compile ?values special-args) + "frem" (compile-jvm-frem compile ?values special-args) + "feq" (compile-jvm-feq compile ?values special-args) + "flt" (compile-jvm-flt compile ?values special-args) + "fgt" (compile-jvm-fgt compile ?values special-args) + "dadd" (compile-jvm-dadd compile ?values special-args) + "dsub" (compile-jvm-dsub compile ?values special-args) + "dmul" (compile-jvm-dmul compile ?values special-args) + "ddiv" (compile-jvm-ddiv compile ?values special-args) + "drem" (compile-jvm-drem compile ?values special-args) + "deq" (compile-jvm-deq compile ?values special-args) + "dlt" (compile-jvm-dlt compile ?values special-args) + "dgt" (compile-jvm-dgt compile ?values special-args) + "iand" (compile-jvm-iand compile ?values special-args) + "ior" (compile-jvm-ior compile ?values special-args) + "ixor" (compile-jvm-ixor compile ?values special-args) + "ishl" (compile-jvm-ishl compile ?values special-args) + "ishr" (compile-jvm-ishr compile ?values special-args) + "iushr" (compile-jvm-iushr compile ?values special-args) + "land" (compile-jvm-land compile ?values special-args) + "lor" (compile-jvm-lor compile ?values special-args) + "lxor" (compile-jvm-lxor compile ?values special-args) + "lshl" (compile-jvm-lshl compile ?values special-args) + "lshr" (compile-jvm-lshr compile ?values special-args) + "lushr" (compile-jvm-lushr compile ?values special-args) + "d2f" (compile-jvm-d2f compile ?values special-args) + "d2i" (compile-jvm-d2i compile ?values special-args) + "d2l" (compile-jvm-d2l compile ?values special-args) + "f2d" (compile-jvm-f2d compile ?values special-args) + "f2i" (compile-jvm-f2i compile ?values special-args) + "f2l" (compile-jvm-f2l compile ?values special-args) + "i2b" (compile-jvm-i2b compile ?values special-args) + "i2c" (compile-jvm-i2c compile ?values special-args) + "i2d" (compile-jvm-i2d compile ?values special-args) + "i2f" (compile-jvm-i2f compile ?values special-args) + "i2l" (compile-jvm-i2l compile ?values special-args) + "i2s" (compile-jvm-i2s compile ?values special-args) + "l2d" (compile-jvm-l2d compile ?values special-args) + "l2f" (compile-jvm-l2f compile ?values special-args) + "l2i" (compile-jvm-l2i compile ?values special-args) + "l2s" (compile-jvm-l2s compile ?values special-args) + "l2b" (compile-jvm-l2b compile ?values special-args) + "c2b" (compile-jvm-c2b compile ?values special-args) + "c2s" (compile-jvm-c2s compile ?values special-args) + "c2i" (compile-jvm-c2i compile ?values special-args) + "c2l" (compile-jvm-c2l compile ?values special-args) + "s2l" (compile-jvm-s2l compile ?values special-args) + "b2l" (compile-jvm-b2l compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["jvm" proc-name])))) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj new file mode 100644 index 000000000..1beb9aa21 --- /dev/null +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -0,0 +1,1269 @@ +(ns lux.compiler.jvm.rt + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]] + [type :as &type] + [lexer :as &lexer] + [parser :as &parser] + [analyser :as &analyser] + [optimizer :as &o] + [host :as &host]) + [lux.type.host :as &host-type] + [lux.host.generics :as &host-generics] + [lux.analyser.base :as &a] + [lux.compiler.jvm.base :as &&]) + (:import (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor + AnnotationVisitor))) + +;; [Utils] +(def init-method "") + +;; [Resources] +(def compile-Function-class + (|do [_ (return nil) + :let [super-class "java/lang/Object" + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER + Opcodes/ACC_ABSTRACT + ;; Opcodes/ACC_INTERFACE + ) + &&/function-class nil super-class (into-array String [])) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) + (doto (.visitEnd)))) + =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (dotimes [arity* &&/num-apply-variants] + (let [arity (inc arity*)] + (if (= 1 arity) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) + (.visitCode) + (-> (.visitVarInsn Opcodes/ALOAD idx) + (->> (dotimes [idx arity]))) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) + (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) + (.visitVarInsn Opcodes/ALOAD arity) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))))]] + (&&/save-class! (second (string/split &&/function-class #"/")) + (.toByteArray (doto =class .visitEnd))))) + +(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] + (|let [_ (let [$begin (new Label) + $not-rec (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size + (.visitInsn Opcodes/ISUB) ;; sub-index + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple + (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size + (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem + (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-rec) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $is-last (new Label) + $must-copy (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index + (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem + (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem + (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;; + ;; Must recurse + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitInsn Opcodes/DUP) ;; tuple, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size + (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem + (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem + (.visitInsn Opcodes/AALOAD) ;; tuple-tail + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple + (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size + (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1 + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size* + (.visitInsn Opcodes/ISUB) ;; tuple-tail, index* + (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail + (.visitVarInsn Opcodes/ASTORE 0) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $must-copy) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $is-last) ;; tuple-size, index-last-elem + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 0) ;; tuple + (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index + (.visitInsn Opcodes/AALOAD) ;; elem + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$begin (new Label) + $just-return (new Label) + $then (new Label) + $further (new Label) + $not-right (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLabel $begin) + (.visitVarInsn Opcodes/ILOAD 1) ;; tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum + (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag' + &&/unwrap-int ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag + (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag + (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $then) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last? + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last? + (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return) + (.visitJumpInsn Opcodes/GOTO $further) + (.visitLabel $just-return) + (.visitInsn Opcodes/POP2) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 2)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitLabel $further) ;; tag, sum-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum + (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index? + (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last? + (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/ISUB) ;; sub-tag + (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum + (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx + (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag + (.visitVarInsn Opcodes/ISTORE 1) ;; + (.visitJumpInsn Opcodes/GOTO $begin) + (.visitLabel $not-right) ;; tag, sum-tag + (.visitInsn Opcodes/POP2) + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; I commented-out some parts because a null-check was + ;; done to ensure variants were never created with null + ;; values (this would interfere later with + ;; pattern-matching). + ;; Since Lux itself doesn't have null values as part of + ;; the language, the burden of ensuring non-nulls was + ;; shifted to library code dealing with host-interop, to + ;; ensure variant-making was as fast as possible. + ;; The null-checking code was left as comments in case I + ;; ever change my mind. + _ (let [;; $is-null (new Label) + ] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitJumpInsn Opcodes/IFNULL $is-null) + (.visitLdcInsn (int 3)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ILOAD 0) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 2)) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + ;; (.visitLabel $is-null) + ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + ;; (.visitInsn Opcodes/DUP) + ;; (.visitLdcInsn "Can't create variant for null pointer") + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + ;; (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(defn ^:private low-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. + (.visitLdcInsn (int -1)) + (.visitInsn Opcodes/I2L) + ;; Then do a bitwise and. + (.visitInsn Opcodes/LAND) + )) + +(defn ^:private high-4b [^MethodVisitor =method] + (doto =method + ;; Assume there is a long at the top of the stack... + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + )) + +(defn ^:private swap2 [^MethodVisitor =method] + (doto =method + ;; X2, Y2 + (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X2 + )) + +(defn ^:private swap2x1 [^MethodVisitor =method] + (doto =method + ;; X1, Y2 + (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X1 + )) + +(defn ^:private bit-set-64? [^MethodVisitor =method] + (doto =method + ;; L, I + (.visitLdcInsn (long 1)) ;; L, I, L + (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L + (.visitInsn Opcodes/POP2) ;; L, L, I + (.visitInsn Opcodes/LSHL) ;; L, L + (.visitInsn Opcodes/LAND) ;; L + (.visitLdcInsn (long 0)) ;; L, L + (.visitInsn Opcodes/LCMP) ;; I + )) + +(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] + (|let [deg-bits 64 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) + ;; Based on: http://stackoverflow.com/a/31629280/6823464 + (.visitCode) + ;; Bottom part + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Middle part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) + ;; Join middle and bottom + (.visitInsn Opcodes/LADD) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Top part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + ;; Join top with rest + (.visitInsn Opcodes/LADD) + ;; Return + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) + (.visitCode) + ;; Based on: http://stackoverflow.com/a/8510587/6823464 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LDIV) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) + (.visitCode) + ;; Translate high bytes + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Translate low bytes + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Combine and return + (.visitInsn Opcodes/DADD) + (.visitInsn Opcodes/DRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) + (.visitCode) + ;; Drop any excess + (.visitVarInsn Opcodes/DLOAD 0) + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + ;; Shift upper half, but retain remaining decimals + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Make a copy, so the lower half can be extracted + (.visitInsn Opcodes/DUP2) + ;; Get that lower half + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Turn it into a deg + (.visitInsn Opcodes/D2L) + ;; Turn the upper half into deg too + swap2 + (.visitInsn Opcodes/D2L) + ;; Combine both pieces + (.visitInsn Opcodes/LADD) + ;; FINISH + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int 0)) ;; {carry} + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} + (.visitLdcInsn (int 5)) + (.visitInsn Opcodes/IMUL) + (.visitInsn Opcodes/IADD) ;; {next-raw-digit} + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 0) + swap2x1 + (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IDIV) ;; {next-carry} + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 0) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) + (.visitCode) + ;; Initialize digits array. + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ILOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 + (.visitVarInsn Opcodes/ASTORE 1) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitVarInsn Opcodes/ILOAD 0) ;; {times} + (.visitLabel $loop-start) + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + ;; {times} + (.visitVarInsn Opcodes/ILOAD 0) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} + (.visitVarInsn Opcodes/ASTORE 1) ;; {times} + ;; Decrement index + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + ;; {times-1} + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits + (.visitLdcInsn (int 0)) ;; {carry} + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + ;; {carry} + (.visitVarInsn Opcodes/ALOAD 3) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; {carry} + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {carry, dL} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} + (.visitInsn Opcodes/IADD) + (.visitInsn Opcodes/IADD) ;; {raw-next-digit} + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} + (.visitVarInsn Opcodes/ALOAD 3) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} + (.visitLdcInsn (int 10)) + (.visitInsn Opcodes/IDIV) ;; {next-carry} + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn "") ;; {text} + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitInsn Opcodes/BALOAD) ;; {text, digit} + (.visitLdcInsn (int 10)) ;; {text, digit, radix} + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $not-set (new Label) + $next-iteration (new Label) + $normal-path (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + ;; A quick corner-case to handle. + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $normal-path) + (.visitLdcInsn ".0") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $normal-path) + ;; Normal case + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 3) ;; digits + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + ;; Prepare text to return. + (.visitVarInsn Opcodes/ALOAD 3) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") + (.visitLdcInsn ".") + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; Trim unnecessary 0s at the end... + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + bit-set-64? + (.visitJumpInsn Opcodes/IFEQ $next-iteration) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") + (.visitVarInsn Opcodes/ALOAD 3) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") + (.visitVarInsn Opcodes/ASTORE 3) + (.visitJumpInsn Opcodes/GOTO $next-iteration) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $next-iteration) + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $not-set (new Label) + $next-iteration (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn (int deg-bits)) + (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) + (.visitVarInsn Opcodes/ASTORE 2) ;; digits + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") + ;; Set digit + (.visitVarInsn Opcodes/ALOAD 2) + (.visitVarInsn Opcodes/ILOAD 1) + swap2x1 + (.visitInsn Opcodes/BASTORE) + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $is-less-than (new Label) + $is-equal (new Label)] + ;; [B0 <= [B1 + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) + (.visitCode) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int deg-bits)) + (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {D0} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {D0, D1} + (.visitInsn Opcodes/DUP2) + (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) + (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) + ;; Is greater than... + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $is-less-than) + (.visitInsn Opcodes/POP2) + (.visitLdcInsn true) + (.visitInsn Opcodes/IRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $is-equal) + ;; Increment index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label) + $simple-sub (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) + (.visitCode) + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} + (.visitInsn Opcodes/BALOAD) + (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} + (.visitInsn Opcodes/DUP2) + (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; Since $0 < $1 + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) ;; $1 - $0 + (.visitLdcInsn (byte 10)) + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) + ;; Prepare to iterate... + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Subtract 1 from next digit + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $simple-sub) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 2) + swap2x1 + (.visitInsn Opcodes/BASTORE) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$loop-start (new Label) + $do-a-round (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) + (.visitCode) + (.visitLdcInsn (int (dec deg-bits))) + (.visitVarInsn Opcodes/ISTORE 2) ;; Index + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitJumpInsn Opcodes/IFGE $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} + (.visitVarInsn Opcodes/ALOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} + (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") + (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits + ;; Decrement index + (.visitVarInsn Opcodes/ILOAD 2) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitVarInsn Opcodes/ISTORE 2) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + $loop-start (new Label) + $do-a-round (new Label) + $skip-power (new Label) + $iterate (new Label) + $bad-format (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + ;; Check prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ".") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $bad-format) + ;; Check if size is valid + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . + (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) + ;; Initialization + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") + (.visitLabel $to) + (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ISTORE 1) ;; Index + (.visitLdcInsn (long 0)) + (.visitVarInsn Opcodes/LSTORE 2) ;; Output + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $loop-start) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int deg-bits)) + (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) + (.visitVarInsn Opcodes/LLOAD 2) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $do-a-round) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") + (.visitInsn Opcodes/DUP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") + (.visitJumpInsn Opcodes/IFNE $skip-power) + ;; Subtract power + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") + (.visitVarInsn Opcodes/ASTORE 0) + ;; Set bit on output + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 1)) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int (dec deg-bits))) + (.visitInsn Opcodes/SWAP) + (.visitInsn Opcodes/ISUB) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LOR) + (.visitVarInsn Opcodes/LSTORE 2) + (.visitJumpInsn Opcodes/GOTO $iterate) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $skip-power) + (.visitInsn Opcodes/POP2) + ;; (.visitJumpInsn Opcodes/GOTO $iterate) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $iterate) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/IADD) + (.visitVarInsn Opcodes/ISTORE 1) + ;; Iterate + (.visitJumpInsn Opcodes/GOTO $loop-start) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitLabel $bad-format) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))] + nil)) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] + (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 + _ (let [$from (new Label) + $to (new Label) + $handler (new Label) + + $good-start (new Label) + $short-enough (new Label) + $bad-digit (new Label) + $out-of-bounds (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + ;; Remove the + at the beginning... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitLdcInsn "+") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFNE $good-start) + ;; Doesn't start with + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Starts with + + (.visitLabel $good-start) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... + ;; Begin parsing processs + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 18)) + (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) + ;; Too long + ;; Get prefix... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... + ;; Get last digit... + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/ISUB) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + (.visitLdcInsn (int 10)) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") + ;; Test last digit... + (.visitInsn Opcodes/DUP) + (.visitJumpInsn Opcodes/IFLT $bad-digit) + ;; Good digit... + ;; Stack: prefix::L, prefix::L, last-digit::I + (.visitInsn Opcodes/I2L) + ;; Build the result... + swap2 + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L + (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L + swap2 ;; Stack: result::L, result::L, prefix::L + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $out-of-bounds) + ;; Within bounds + ;; Stack: result::L + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Out of bounds + (.visitLabel $out-of-bounds) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; Bad digit... + (.visitLabel $bad-digit) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + ;; 18 chars or less + (.visitLabel $short-enough) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172 + _ (let [$too-big (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitLdcInsn "+") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $too-big) + ;; then + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + ;; else + (.visitLabel $too-big) + ;; Set up parts of the number string... + ;; First digits + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/LUSHR) + (.visitLdcInsn (long 5)) + (.visitInsn Opcodes/LDIV) ;; quot + ;; Last digit + (.visitInsn Opcodes/DUP2) + (.visitLdcInsn (long 10)) + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) + swap2 + (.visitInsn Opcodes/LSUB) ;; quot, rem + ;; Conversion to string... + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem* + (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem* + (.visitInsn Opcodes/POP) ;; rem*, quot + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot* + (.visitInsn Opcodes/SWAP) ;; quot*, rem* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 + _ (let [$simple-case (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGE $simple-case) + ;; else + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitLdcInsn (int 32)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + ;; then + (.visitLabel $simple-case) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") + (.visitInsn Opcodes/LADD) + (.visitInsn Opcodes/LCMP) + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 + _ (let [$case-1 (new Label) + $0 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLT $case-1) + ;; Test #2 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFGT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LDIV) + (.visitInsn Opcodes/LRETURN) + ;; Case #1 + (.visitLabel $case-1) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $0) + ;; 1 + (.visitLdcInsn (long 1)) + (.visitInsn Opcodes/LRETURN) + ;; 0 + (.visitLabel $0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 + _ (let [$test-2 (new Label) + $case-2 (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) + (.visitCode) + ;; Test #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFLE $test-2) + ;; Case #1 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitInsn Opcodes/LREM) + (.visitInsn Opcodes/LRETURN) + ;; Test #2 + (.visitLabel $test-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") + (.visitJumpInsn Opcodes/IFLT $case-2) + ;; Case #3 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitVarInsn Opcodes/LLOAD 2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") + (.visitInsn Opcodes/LRETURN) + ;; Case #2 + (.visitLabel $case-2) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitInsn Opcodes/LRETURN) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (.visitMaxs 0 0) + (.visitEnd)))] + nil))) + +(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn "Invalid expression for pattern-matching.") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil)) + +(def compile-LuxRT-class + (|do [_ (return nil) + :let [full-name &&/lux-utils-class + super-class (&host-generics/->bytecode-class-name "java.lang.Object") + tag-sig (&host-generics/->type-signature "java.lang.String") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + full-name nil super-class (into-array String []))) + =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) + (.visitEnd)) + =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitLdcInsn "LOG: ") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I + (.visitInsn Opcodes/ACONST_NULL) ;; I? + (.visitLdcInsn &/unit-tag) ;; I?U + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I + (.visitLdcInsn "") ;; I? + (.visitVarInsn Opcodes/ALOAD 0) ;; I?O + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto =class + (compile-LuxRT-pm-methods) + (compile-LuxRT-adt-methods) + (compile-LuxRT-nat-methods) + (compile-LuxRT-deg-methods))]] + (&&/save-class! (second (string/split &&/lux-utils-class #"/")) + (.toByteArray (doto =class .visitEnd))))) -- cgit v1.2.3 From b0114f4871a6a2654fa2edc667a635a97ae76b19 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 16 Feb 2017 20:09:52 -0400 Subject: - Implemented several new procedures. - Improved Lux-to-JS interactions. - Parallel compilation works for the JS backend. - Added more primitive functionality to the JS runtime. - More common procedures. --- luxc/src/lux/analyser/proc/common.clj | 125 +++++++++++++++---- luxc/src/lux/compiler/js.clj | 3 +- luxc/src/lux/compiler/js/base.clj | 54 ++++++--- luxc/src/lux/compiler/js/lux.clj | 22 ++-- luxc/src/lux/compiler/js/proc/common.clj | 192 +++++++++++++++++++++--------- luxc/src/lux/compiler/js/rt.clj | 108 +++++++++++++++-- luxc/src/lux/compiler/jvm/proc/common.clj | 144 ++++++++++++++++++++-- luxc/src/lux/compiler/jvm/rt.clj | 30 ++++- 8 files changed, 551 insertions(+), 127 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 3bbc47e88..4a4048c1c 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -6,7 +6,7 @@ [type :as &type]) (lux.analyser [base :as &&]))) -(defn ^:private analyse-lux-== [analyse exo-type ?values] +(defn ^:private analyse-lux-is [analyse exo-type ?values] (&type/with-var (fn [$var] (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] @@ -15,7 +15,7 @@ _ (&type/check exo-type &type/Bool) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) + (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) (do-template [ ] (defn [analyse exo-type ?values] @@ -31,6 +31,66 @@ ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text =part) + (&/|list))))))) + + ^:private analyse-text-index "index" + ^:private analyse-text-last-index "last-index" + ) + +(defn ^:private analyse-text-clip [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =from (&&/analyse-1 analyse &type/Nat from) + =to (&&/analyse-1 analyse &type/Nat to) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Text)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "clip"]) + (&/|list =text =from =to) + (&/|list))))))) + +(defn ^:private analyse-text-replace-all [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons to-find (&/$Cons replace-with (&/$Nil)))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =to-find (&&/analyse-1 analyse &type/Text to-find) + =replace-with (&&/analyse-1 analyse &type/Text replace-with) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "replace-all"]) + (&/|list =text =to-find =replace-with) + (&/|list))))))) + +(defn ^:private analyse-text-trim [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "trim"]) + (&/|list =text) + (&/|list))))))) + +(defn ^:private analyse-text-size [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ["text" "size"]) + (&/|list =text) + (&/|list))))))) + (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] @@ -153,17 +213,20 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|list) (&/|list))))))) - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] + ^:private analyse-int-min-value &type/Int ["int" "min-value"] + ^:private analyse-int-max-value &type/Int ["int" "max-value"] - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] + ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] - ^:private analyse-real-min-value &type/Real ["real" "min-value"] - ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] + ^:private analyse-real-not-a-number &type/Real ["real" "not-a-number"] + ^:private analyse-real-positive-infinity &type/Real ["real" "positive-infinity"] + ^:private analyse-real-negative-infinity &type/Real ["real" "negative-infinity"] ) (do-template [ ] @@ -175,16 +238,23 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] - ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-int-to-real &type/Int &type/Real ["int" "to-real"] + ^:private analyse-real-to-int &type/Real &type/Int ["real" "to-int"] + ^:private analyse-real-hash &type/Real &type/Nat ["real" "hash"] + + ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"] - ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] - ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] + ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] + ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ^:private analyse-lux-log! &type/Text &/$UnitT ["io" "log!"] + ^:private analyse-lux-log &type/Text &/$UnitT ["io" "log"] + ^:private analyse-lux-error &type/Text &type/Bottom ["io" "error"] ) (defn ^:private analyse-array-new [analyse exo-type ?values] @@ -245,16 +315,23 @@ (case category "lux" (case proc - "==" (analyse-lux-== analyse exo-type ?values)) + "is" (analyse-lux-is analyse exo-type ?values)) "io" (case proc - "log!" (analyse-lux-log! analyse exo-type ?values)) + "log" (analyse-lux-log analyse exo-type ?values) + "error" (analyse-lux-error analyse exo-type ?values)) "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) - "append" (analyse-text-append analyse exo-type ?values)) + "append" (analyse-text-append analyse exo-type ?values) + "clip" (analyse-text-clip analyse exo-type ?values) + "index" (analyse-text-index analyse exo-type ?values) + "last-index" (analyse-text-last-index analyse exo-type ?values) + "size" (analyse-text-size analyse exo-type ?values) + "replace-all" (analyse-text-replace-all analyse exo-type ?values) + "trim" (analyse-text-trim analyse exo-type ?values)) "bit" (case proc @@ -305,6 +382,7 @@ "min-value" (analyse-int-min-value analyse exo-type ?values) "max-value" (analyse-int-max-value analyse exo-type ?values) "to-nat" (analyse-int-to-nat analyse exo-type ?values) + "to-real" (analyse-int-to-real analyse exo-type ?values) ) "deg" @@ -337,7 +415,12 @@ "decode" (analyse-real-decode analyse exo-type ?values) "min-value" (analyse-real-min-value analyse exo-type ?values) "max-value" (analyse-real-max-value analyse exo-type ?values) + "not-a-number" (analyse-real-not-a-number analyse exo-type ?values) + "positive-infinity" (analyse-real-positive-infinity analyse exo-type ?values) + "negative-infinity" (analyse-real-negative-infinity analyse exo-type ?values) "to-deg" (analyse-real-to-deg analyse exo-type ?values) + "to-int" (analyse-real-to-int analyse exo-type ?values) + "hash" (analyse-real-hash analyse exo-type ?values) ) "char" diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index a60afbc23..2e7d01d44 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -130,8 +130,7 @@ (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file source-dirs file-name) :let [file-hash (hash file-content) - ;; compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs)) - compile-module!! (partial compile-module source-dirs)]] + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] ;; (&/|eitherL (&&cache/load name)) (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] (|do [module-exists? (&a-module/exists? name)] diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 62d440d6d..044a4f099 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -54,15 +54,31 @@ (&/adt->text obj) ))) +(defn ^:private _toString_simple [^String obj] + (reify JSObject + (isFunction [self] true) + (call [self this args] + obj + ))) + (def ^:private i64-mask (dec (bit-shift-left 1 32))) -(defn ^:private to-i64 [value] +(deftype I64 [value] + JSObject + (getMember [self member] + (condp = member + "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) + "L" (-> value (bit-and i64-mask) int) + ;; else + (assert false (str "I64#getMember = " member))))) + +(defn ^:private encode-char [value] (reify JSObject (getMember [self member] (condp = member - "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) - "L" (-> value (bit-and i64-mask) int) + "C" value + ;; "toString" (_toString_simple value) ;; else - (assert false (str "to-i64#getMember = " member)))))) + (assert false (str "encode-char#getMember = " member)))))) (deftype LuxJsObject [obj] JSObject @@ -73,7 +89,10 @@ (new LuxJsObject value) (instance? java.lang.Long value) - (to-i64 value) + (new I64 value) + + (instance? java.lang.Character value) + (encode-char (str value)) :else value))) @@ -81,15 +100,7 @@ (condp = member "toString" (_toString_ obj) "length" (alength obj) - "slice" (let [wrap-lux-obj #(cond (instance? lux-obj-class %) - (new LuxJsObject %) - - (instance? java.lang.Long %) - (to-i64 %) - - :else - %)] - (_slice_ wrap-lux-obj obj)) + "slice" (_slice_ #(new LuxJsObject %) obj) ;; else (assert false (str "wrap-lux-obj#getMember = " member))))) @@ -102,6 +113,13 @@ (and (.hasMember js-object "H") (.hasMember js-object "L"))) +(defn ^:private encoded-char? [^ScriptObjectMirror js-object] + (.hasMember js-object "C")) + +(defn ^:private decode-char [^ScriptObjectMirror js-object] + (-> (.getMember js-object "C") + (.charAt 0))) + (defn ^:private parse-int64 [^ScriptObjectMirror js-object] (+ (-> (.getMember js-object "H") long @@ -122,6 +140,9 @@ (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) + (instance? I64 js-object) + (.-value ^I64 js-object) + ;; (instance? Undefined js-object) ;; (assert false "UNDEFINED") @@ -149,6 +170,9 @@ (int64? js-object) (parse-int64 js-object) + (encoded-char? js-object) + (decode-char js-object) + :else (assert false (str "Unknown kind of JS object: " js-object)))) @@ -169,5 +193,5 @@ (let [^String module* (&host/->module-class module) module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] (do (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator name ".js") (.getBytes script)))))]] + (&&/write-file (str module-dir java.io.File/separator (&host/def-name name) ".js") (.getBytes script)))))]] (return nil))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 61f21bf55..f0ad777c6 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -19,8 +19,11 @@ )) ;; [Utils] +(defn ^:private js-module [module] + (string/replace module "/" "$")) + (defn ^:private js-var-name [module name] - (str (string/replace module "/" "$") "$" (&host/def-name name))) + (str (js-module module) "$" (&host/def-name name))) (defn ^:private captured-name [register] (str "$" register)) @@ -49,7 +52,7 @@ (return (str value))) (defn compile-char [value] - (return (str "\"" value "\""))) + (return (str "{C:\"" value "\"}"))) (defn compile-text [?value] (return (pr-str ?value))) @@ -279,7 +282,7 @@ (defn compile-function [compile arity ?scope ?env ?body] (|do [:let [??scope (&/|reverse ?scope) - function-name (str (&host/->module-class (&/|head ??scope)) + function-name (str (js-module (&/|head ??scope)) "$" (&host/location (&/|tail ??scope))) func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) @@ -323,12 +326,11 @@ (defn compile-def [compile ?name ?body def-meta] (|do [module-name &/get-module-name - class-loader &/loader - :let [var-name (js-var-name module-name ?name)]] + class-loader &/loader] (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) (&/$Some (&/$IdentA [r-module r-name])) (if (= 1 (&/|length def-meta)) - (|do [def-value (&&/run-js! var-name) + (|do [def-value (&&/run-js! (js-var-name r-module r-name)) def-type (&a-module/def-type r-module r-name) _ (&/without-repl-closure (&a-module/define module-name ?name def-type def-meta def-value))] @@ -339,7 +341,8 @@ (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") _ - (|do [=body (compile ?body) + (|do [:let [var-name (js-var-name module-name ?name)] + =body (compile ?body) :let [def-js (str "var " var-name " = " =body ";") is-type? (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) (&/$Some (&/$BoolA true)) @@ -348,8 +351,9 @@ _ false) def-type (&a/expr-type* ?body) - _ (&/|log! (string/replace def-js "" "^@"))] - _ (&&/run-js! def-js) + ;; _ (&/|log! (string/replace def-js "" "^@")) + ] + _ (&&/save-js! ?name def-js) def-value (&&/run-js!+ var-name) _ (&/without-repl-closure (&a-module/define module-name ?name def-type def-meta def-value)) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 385761dbe..23454914e 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -10,7 +10,8 @@ [optimizer :as &o]) [lux.analyser.base :as &a] (lux.compiler.js [base :as &&] - [rt :as &&rt]))) + [rt :as &&rt] + [lux :as &&lux]))) ;; [Resources] ;; (do-template [ ] @@ -62,22 +63,11 @@ ;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR ;; ) -;; (defn ^:private compile-lux-== [compile ?values special-args] -;; (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?left) -;; _ (compile ?right) -;; :let [$then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitJumpInsn Opcodes/IF_ACMPEQ $then) -;; ;; else -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") -;; (.visitLabel $end))]] -;; (return nil))) +(defn ^:private compile-lux-is [compile ?values special-args] + (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] + =left (compile ?left) + =right (compile ?right)] + (return (str "(" =left " === " =right ")")))) (do-template [ ] (defn [compile ?values special-args] @@ -132,11 +122,42 @@ (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str &&rt/LuxRT "." "(" =x ")")))) + (return (str &&rt/LuxRT "." "(" =x ")")) + )) ^:private compile-int-encode "encodeI64" ^:private compile-nat-encode "encodeN64" ^:private compile-deg-encode "encodeD64" + + ^:private compile-int-decode "decodeI64" + ^:private compile-nat-decode "decodeN64" + ^:private compile-deg-decode "decodeD64" + + ^:private compile-real-decode "decodeReal" + + ^:private compile-real-hash "hashReal" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + ( ))) + + ^:private compile-nat-min-value &&lux/compile-nat 0 + ^:private compile-nat-max-value &&lux/compile-nat -1 + + ^:private compile-int-min-value &&lux/compile-int Long/MIN_VALUE + ^:private compile-int-max-value &&lux/compile-int Long/MAX_VALUE + + ^:private compile-deg-min-value &&lux/compile-deg 0 + ^:private compile-deg-max-value &&lux/compile-deg -1 + + ^:private compile-real-min-value &&lux/compile-real (* -1.0 Double/MAX_VALUE) + ^:private compile-real-max-value &&lux/compile-real Double/MAX_VALUE + + ^:private compile-real-not-a-number &&lux/compile-real "NaN" + ^:private compile-real-positive-infinity &&lux/compile-real "Infinity" + ^:private compile-real-negative-infinity &&lux/compile-real "-Infinity" ) (defn ^:private compile-real-encode [compile ?values special-args] @@ -166,22 +187,6 @@ ;; (.visitLabel $end))]] ;; (return nil))) -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Nil) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; :let [_ (doto *writer* -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long - -;; ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long -;; ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long -;; ) - ;; (do-template [ ] ;; (defn [compile ?values special-args] ;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -248,6 +253,26 @@ ^:private compile-int-to-nat ) +(defn ^:private compile-int-to-real [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.toNumberI64(" =x ")")))) + +(defn ^:private compile-real-to-int [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" =x ")")))) + +(defn ^:private compile-deg-to-real [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.degToReal(" =x ")")))) + +(defn ^:private compile-real-to-deg [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.realToDeg(" =x ")")))) + (defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) @@ -260,29 +285,78 @@ =y (compile ?y)] (return (str =x ".concat(" =y ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "LuxRT" "." "(" =text "," =part ")")))) + + ^:private compile-text-last-index "lastIndex" + ^:private compile-text-index "index" + ) + +(defn ^:private compile-text-clip [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] + =text (compile ?text) + =from (compile ?from) + =to (compile ?to)] + (return (str "LuxRT.clip(" (str =text "," =from "," =to) ")")))) + +(defn ^:private compile-text-replace-all [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?to-find (&/$Cons ?replace-with (&/$Nil)))) ?values] + =text (compile ?text) + =to-find (compile ?to-find) + =replace-with (compile ?replace-with)] + (return (str "LuxRT.replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) + +(defn ^:private compile-text-trim [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "(" =text ").trim()")))) + +(defn ^:private compile-text-size [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) + (defn ^:private compile-char-to-text [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] - (compile ?x))) + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "(" =x ").C")))) -(defn ^:private compile-lux-log! [compile ?values special-args] +(defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.log(" =message ")")))) +(defn ^:private compile-lux-error [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + =message (compile ?message)] + (return (str "LuxRT.error(" =message ")")))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category - ;; "lux" - ;; (case proc-name - ;; "==" (compile-lux-== compile ?values special-args)) + "lux" + (case proc-name + "is" (compile-lux-is compile ?values special-args)) "io" (case proc-name - "log!" (compile-lux-log! compile ?values special-args)) + "log" (compile-lux-log compile ?values special-args) + "error" (compile-lux-error compile ?values special-args)) "text" (case proc-name "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) + "append" (compile-text-append compile ?values special-args) + "clip" (compile-text-clip compile ?values special-args) + "index" (compile-text-index compile ?values special-args) + "last-index" (compile-text-last-index compile ?values special-args) + "size" (compile-text-size compile ?values special-args) + "replace-all" (compile-text-replace-all compile ?values special-args) + "trim" (compile-text-trim compile ?values special-args) + ) ;; "bit" ;; (case proc-name @@ -308,9 +382,9 @@ "=" (compile-nat-eq compile ?values special-args) "<" (compile-nat-lt compile ?values special-args) "encode" (compile-nat-encode compile ?values special-args) - ;; "decode" (compile-nat-decode compile ?values special-args) - ;; "max-value" (compile-nat-max-value compile ?values special-args) - ;; "min-value" (compile-nat-min-value compile ?values special-args) + "decode" (compile-nat-decode compile ?values special-args) + "max-value" (compile-nat-max-value compile ?values special-args) + "min-value" (compile-nat-min-value compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) ;; "to-char" (compile-nat-to-char compile ?values special-args) ) @@ -325,10 +399,11 @@ "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) - ;; "decode" (compile-int-decode compile ?values special-args) - ;; "max-value" (compile-int-max-value compile ?values special-args) - ;; "min-value" (compile-int-min-value compile ?values special-args) + "decode" (compile-int-decode compile ?values special-args) + "max-value" (compile-int-max-value compile ?values special-args) + "min-value" (compile-int-min-value compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "to-real" (compile-int-to-real compile ?values special-args) ) "deg" @@ -341,10 +416,10 @@ "=" (compile-deg-eq compile ?values special-args) "<" (compile-deg-lt compile ?values special-args) "encode" (compile-deg-encode compile ?values special-args) - ;; "decode" (compile-deg-decode compile ?values special-args) - ;; "max-value" (compile-deg-max-value compile ?values special-args) - ;; "min-value" (compile-deg-min-value compile ?values special-args) - ;; "to-real" (compile-deg-to-real compile ?values special-args) + "decode" (compile-deg-decode compile ?values special-args) + "max-value" (compile-deg-max-value compile ?values special-args) + "min-value" (compile-deg-min-value compile ?values special-args) + "to-real" (compile-deg-to-real compile ?values special-args) "scale" (compile-deg-scale compile ?values special-args) ) @@ -358,10 +433,15 @@ "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) "encode" (compile-real-encode compile ?values special-args) - ;; "decode" (compile-real-decode compile ?values special-args) - ;; "max-value" (compile-real-max-value compile ?values special-args) - ;; "min-value" (compile-real-min-value compile ?values special-args) - ;; "to-deg" (compile-real-to-deg compile ?values special-args) + "decode" (compile-real-decode compile ?values special-args) + "max-value" (compile-real-max-value compile ?values special-args) + "min-value" (compile-real-min-value compile ?values special-args) + "not-a-number" (compile-real-not-a-number compile ?values special-args) + "positive-infinity" (compile-real-positive-infinity compile ?values special-args) + "negative-infinity" (compile-real-negative-infinity compile ?values special-args) + "to-deg" (compile-real-to-deg compile ?values special-args) + "to-int" (compile-real-to-int compile ?values special-args) + "hash" (compile-real-hash compile ?values special-args) ) "char" diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index ce5bf5d16..1cb4a6150 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -941,16 +941,50 @@ }) (def ^:private i64-methods - {"makeI64" (str "(function makeI64(high,low) {" + {"TWO_PWR_16" "(1 << 16)" + "TWO_PWR_32" "((1 << 16) * (1 << 16))" + "TWO_PWR_64" "(((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16)))" + "TWO_PWR_63" "((((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16))) / 2)" + "getLowBitsUnsigned" (str "(function getLowBitsUnsigned(i64) {" + "return (i64.L >= 0) ? i64.L : (LuxRT.TWO_PWR_32 + i64.L);" + "})") + "toNumberI64" (str "(function toNumberI64(i64) {" + "return (i64.H * LuxRT.TWO_PWR_32) + LuxRT.getLowBitsUnsigned(i64);" + "})") + "fromNumberI64" (str "(function fromNumberI64(num) {" + (str "if (isNaN(num)) {" + "return LuxRT.ZERO;" + "}") + (str "else if (num <= -LuxRT.TWO_PWR_63) {" + "return LuxRT.MIN_VALUE_I64;" + "}") + (str "else if ((num + 1) >= LuxRT.TWO_PWR_63) {" + "return LuxRT.MAX_VALUE_I64;" + "}") + (str "else if (num < 0) {" + "return LuxRT.negateI64(LuxRT.fromNumberI64(-num));" + "}") + (str "else {" + "return LuxRT.makeI64((num / LuxRT.TWO_PWR_32), (num % LuxRT.TWO_PWR_32));" + "}") + "})") + "makeI64" (str "(function makeI64(high,low) {" "return { H: (high|0), L: (low|0)};" "})") - "MIN_VALUE" "{ H: 0x80000000, L: 0}" - "ONE" "{ H: 0, L: 1}" + "MIN_VALUE_I64" "{ H: (0x80000000|0), L: (0|0)}" + "MAX_VALUE_I64" "{ H: (0x7FFFFFFF|0), L: (0xFFFFFFFF|0)}" + "ONE" "{ H: (0|0), L: (1|0)}" + "ZERO" "{ H: (0|0), L: (0|0)}" "notI64" (str "(function notI64(i64) {" "return LuxRT.makeI64(~i64.H,~i64.L);" "})") "negateI64" (str "(function negateI64(i64) {" - "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.makeI64(0,1));" + (str "if(LuxRT.eqI64(LuxRT.MIN_VALUE_I64,i64)) {" + "return LuxRT.MIN_VALUE_I64;" + "}") + (str "else {" + "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.ONE);" + "}") "})") "eqI64" (str "(function eqI64(l,r) {" "return (l.H === r.H) && (l.L === r.L);" @@ -1045,14 +1079,14 @@ ;; Special case: L = 0 "return l;" "}") - (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE)) {" + (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE_I64)) {" ;; Special case: L = MIN (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {" ;; Special case: L = MIN, R = 1|-1 - "return LuxRT.MIN_VALUE;" + "return LuxRT.MIN_VALUE_I64;" "}" ;; Special case: L = R = MIN - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" "return LuxRT.ONE;" "}" ;; Special case: L = MIN @@ -1073,7 +1107,7 @@ "}") "}") "}" - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {" + "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" ;; Special case: R = MIN "return LuxRT.makeI64(0,0);" "}") @@ -1093,7 +1127,7 @@ "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));" "}") ;; Common case - (str "var res = { H: 0, L: 0};" + (str "var res = LuxRT.ZERO;" "var rem = l;" (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {" "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));" @@ -1124,16 +1158,16 @@ "}") ;; If input < 0 (str "if(input.H < 0) {" - (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE)) {" + (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE_I64)) {" "var radix = LuxRT.makeI64(0,10);" "var div = LuxRT.divI64(input,radix);" "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);" "return LuxRT.encodeI64(div).concat(rem.L+'');" "}") "}" - "else {" - "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" - "}") + (str "else {" + "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" + "}")) ;; If input > 0 (str "var chunker = LuxRT.makeI64(0,1000000);" "var rem = input;" @@ -1176,6 +1210,11 @@ "return '+'.concat(LuxRT.encodeI64(input));" "}") "})") + "ltN64" (str "(function ltN64(l,r) {" + "var li = LuxRT.addI64(l,LuxRT.MIN_VALUE_I64);" + "var ri = LuxRT.addI64(r,LuxRT.MIN_VALUE_I64);" + "return LuxRT.ltI64(li,ri);" + "})") }) (def ^:private io-methods @@ -1183,6 +1222,48 @@ "console.log(message);" (str "return " &&/unit ";") "})") + "error" (str "(function error(message) {" + "throw new Error(message);" + (str "return null;") + "})") + }) + +(def ^:private const-none (str "[0,null," &&/unit "]")) +(defn ^:private make-some [value] + (str "[1,''," value "]")) + +(def ^:private text-methods + {"index" (str "(function index(text,part) {" + "var idx = text.indexOf(part);" + (str (str "if(idx === -1) {" + "return " const-none ";" + "}") + (str "else {" + (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + "}")) + "})") + "lastIndex" (str "(function lastIndex(text,part) {" + "var idx = text.lastIndexOf(part);" + (str (str "if(idx === -1) {" + "return " const-none ";" + "}") + (str "else {" + (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + "}")) + "})") + "clip" (str "(function clip(text,from,to) {" + "var clip = text.substring(from.L,to.L);" + (str (str "if(clip === '') {" + "return " const-none ";" + "}") + (str "else {" + "return " (make-some "clip") ";" + "}")) + "})") + "replaceAll" (str "(function replaceAll(text,toFind,replaceWith) {" + "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" + "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" + "})") }) (def LuxRT "LuxRT") @@ -1192,6 +1273,7 @@ :let [rt-object (str "{" (->> (merge adt-methods i64-methods n64-methods + text-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 4ed8134fd..c48403e52 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -162,7 +162,7 @@ ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR ) -(defn ^:private compile-lux-== [compile ?values special-args] +(defn ^:private compile-lux-is [compile ?values special-args] (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?left) @@ -209,11 +209,11 @@ ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double + ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double + ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double + ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double + ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double + ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double ) (do-template [ ] @@ -450,6 +450,21 @@ ^:private compile-int-to-nat ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + + (.visitInsn ) + )]] + (return nil))) + + ^:private compile-real-to-int &&/unwrap-double Opcodes/D2L &&/wrap-long + ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double + ) + (defn compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -473,7 +488,93 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] (return nil))) -(defn compile-io-log! [compile ?values special-args] +(defn compile-text-clip [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?from) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + _ (compile ?to) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;"))]] + (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?part) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;)I"))] + :let [$not-found (new Label) + $end (new Label) + _ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) + (.visitInsn Opcodes/I2L) + &&/wrap-long + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $not-found) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end))]] + (return nil))) + + ^:private compile-text-index "indexOf" + ^:private compile-text-last-index "lastIndexOf" + ) + +(defn ^:private compile-text-size [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-text-replace-all [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?pattern) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?replacement) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] + (return nil))) + +(defn ^:private compile-text-trim [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "trim" "()Ljava/lang/String;"))]] + (return nil))) + +(defn compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -485,20 +586,41 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) +(defn compile-io-error [compile ?values special-args] + (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Error") + (.visitInsn Opcodes/DUP))] + _ (compile ?message) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "" "(Ljava/lang/String;)V") + (.visitInsn Opcodes/ATHROW))]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" (case proc-name - "==" (compile-lux-== compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args)) "io" (case proc-name - "log!" (compile-io-log! compile ?values special-args)) + "log" (compile-io-log compile ?values special-args) + "error" (compile-io-error compile ?values special-args)) "text" (case proc-name "=" (compile-text-eq compile ?values special-args) - "append" (compile-text-append compile ?values special-args)) + "append" (compile-text-append compile ?values special-args) + "clip" (compile-text-clip compile ?values special-args) + "index" (compile-text-index compile ?values special-args) + "last-index" (compile-text-last-index compile ?values special-args) + "size" (compile-text-size compile ?values special-args) + "replace-all" (compile-text-replace-all compile ?values special-args) + "trim" (compile-text-trim compile ?values special-args) + ) "bit" (case proc-name @@ -562,6 +684,7 @@ "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) + "to-real" (compile-int-to-real compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) ) @@ -575,6 +698,7 @@ "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) "encode" (compile-real-encode compile ?values special-args) + "to-int" (compile-real-to-int compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) ) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 1beb9aa21..303d9ae0a 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1204,6 +1204,33 @@ (.visitEnd))] nil)) +(defn ^:private compile-LuxRT-text-methods [^ClassWriter =class] + (|do [:let [_ (let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)))]] + (return nil))) + (def compile-LuxRT-class (|do [_ (return nil) :let [full-name &&/lux-utils-class @@ -1264,6 +1291,7 @@ (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) (compile-LuxRT-nat-methods) - (compile-LuxRT-deg-methods))]] + (compile-LuxRT-deg-methods) + (compile-LuxRT-text-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) -- cgit v1.2.3 From 277747aee1b0b19e88a0e685299f278201737011 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 18:24:45 -0400 Subject: - Added more common procedures. - Fixed some bugs in the type-checking of some common procedures. - Removed the "_name" field for generated classes. - Now compiling loops in JS. - Did some refactoring to the caching machinery. - Implemented binary, octal and hexadecimal encoding purely in Lux. --- luxc/src/lux/analyser/proc/common.clj | 56 ++++++++++++++++++--------- luxc/src/lux/base.clj | 1 - luxc/src/lux/compiler/js.clj | 7 ++-- luxc/src/lux/compiler/js/lux.clj | 29 ++++++-------- luxc/src/lux/compiler/js/proc/common.clj | 25 +++++++++--- luxc/src/lux/compiler/js/rt.clj | 11 ++++++ luxc/src/lux/compiler/jvm/cache.clj | 66 +++++++++++++------------------- luxc/src/lux/compiler/jvm/lux.clj | 4 -- 8 files changed, 111 insertions(+), 88 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 4a4048c1c..bec0855e1 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -24,7 +24,7 @@ =y (&&/analyse-1 analyse y) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool @@ -38,7 +38,7 @@ =part (&&/analyse-1 analyse &type/Text part) _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" ]) (&/|list =text =part) (&/|list))))))) @@ -71,24 +71,41 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-trim [analyse exo-type ?values] +(defn ^:private analyse-text-size [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Nil)) ?values] =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Text) + _ (&type/check exo-type &type/Nat) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "trim"]) + (&&/$proc (&/T ["text" "size"]) (&/|list =text) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-trim "trim" + ^:private analyse-text-upper-case "upper-case" + ^:private analyse-text-lower-case "lower-case" + ) + +(defn ^:private analyse-text-char [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons idx (&/$Nil))) ?values] =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) + =idx (&&/analyse-1 analyse &type/Nat idx) + _ (&type/check exo-type (&/$AppT &type/Maybe &type/Char)) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "char"]) + (&/|list =text =idx) (&/|list))))))) (do-template [ ] @@ -136,7 +153,7 @@ =y (&&/analyse-1 analyse y) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat @@ -178,7 +195,7 @@ =y (&&/analyse-1 analyse &type/Nat y) _ (&type/check exo-type &type/Deg) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Deg _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list))))))) (do-template [ ] @@ -187,7 +204,7 @@ =x (&&/analyse-1 analyse x) _ (&type/check exo-type &type/Text) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) (let [decode-type (&/$AppT &type/Maybe )] @@ -196,7 +213,7 @@ =x (&&/analyse-1 analyse &type/Text x) _ (&type/check exo-type decode-type) _cursor &/cursor] - (return (&/|list (&&/|meta decode-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))))) ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat @@ -210,7 +227,7 @@ (|do [:let [(&/$Nil) ?values] _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list) (&/|list))))))) ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] @@ -235,7 +252,7 @@ =x (&&/analyse-1 analyse x) _ (&type/check exo-type ) _cursor &/cursor] - (return (&/|list (&&/|meta _cursor + (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] @@ -331,7 +348,10 @@ "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) - "trim" (analyse-text-trim analyse exo-type ?values)) + "trim" (analyse-text-trim analyse exo-type ?values) + "char" (analyse-text-char analyse exo-type ?values) + "upper-case" (analyse-text-upper-case analyse exo-type ?values) + "lower-case" (analyse-text-lower-case analyse exo-type ?values)) "bit" (case proc diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index f449a7b3c..1a9fadf63 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -220,7 +220,6 @@ ("DictA" 1)) ;; [Exports] -(def ^:const name-field "_name") (def ^:const hash-field "_hash") (def ^:const value-field "_value") (def ^:const compiler-field "_compiler") diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 2e7d01d44..5bb97728f 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -71,8 +71,8 @@ (&o/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?fn ?args) - ;; (&o/$loop _register-offset _inits _body) - ;; (&&lux/compile-loop compile-expression _register-offset _inits _body) + (&o/$loop _register-offset _inits _body) + (&&lux/compile-loop compile-expression _register-offset _inits _body) (&o/$iter _register-offset ?args) (&&lux/compile-iter compile-expression _register-offset ?args) @@ -157,8 +157,7 @@ ?state) (&/$Left ?message) - (&/fail* ?message))))))) - ) + (&/fail* ?message)))))))) )) (let [!err! *err*] diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index f0ad777c6..39f943dda 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -91,21 +91,15 @@ =args (&/map% compile ?args)] (return (str =fn "(" (->> =args (&/|interpose ",") (&/fold str "")) ")")))) -;; (defn compile-loop [compile-expression register-offset inits body] -;; (|do [^MethodVisitor *writer* &/get-writer -;; :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) -;; inits)] -;; _ (&/map% (fn [idx+_init] -;; (|do [:let [[idx _init] idx+_init -;; idx+ (+ register-offset idx)] -;; _ (compile-expression nil _init) -;; :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] -;; (return nil))) -;; idxs+inits) -;; :let [$begin (new Label) -;; _ (.visitLabel *writer* $begin)]] -;; (compile-expression $begin body) -;; )) +(defn compile-loop [compile register-offset inits body] + (|do [:let [registers (&/|map #(->> % (+ register-offset) register-name) + (&/|range* 0 (dec (&/|length inits))))] + register-inits (&/map% compile inits) + =body (compile body)] + (return (str "(function _loop(" (->> registers (&/|interpose ",") (&/fold str "")) ") {" + =body + "})(" (->> register-inits (&/|interpose ",") (&/fold str "")) ")")) + )) (defn compile-iter [compile register-offset ?args] ;; Can only optimize if it is a simple expression. @@ -128,7 +122,7 @@ ;; ?args)] ;; (return updates)) (|do [=args (&/map% compile ?args)] - (return (str "_0(" + (return (str "_loop(" (->> =args (&/|interpose ",") (&/fold str "")) ")"))) ) @@ -304,7 +298,8 @@ "\"use strict\";" "var num_args = arguments.length;" "if(num_args == " arity ") {" - "var " (register-name 0) " = " function-name ";" + (str "var " (register-name 0) " = " function-name ";") + (str "var _loop = " function-name ";") func-args (str "while(true) {" "return " =body ";" diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 23454914e..ee381add4 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -310,16 +310,28 @@ =replace-with (compile ?replace-with)] (return (str "LuxRT.replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) -(defn ^:private compile-text-trim [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - =text (compile ?text)] - (return (str "(" =text ").trim()")))) - (defn ^:private compile-text-size [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-char [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] + =text (compile ?text) + =idx (compile ?idx)] + (return (str "LuxRT.textChar(" (str =text "," =idx) ")")))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "(" =text ")." "()")))) + + ^:private compile-text-trim "trim" + ^:private compile-text-upper-case "toUpperCase" + ^:private compile-text-lower-case "toLowerCase" + ) + (defn ^:private compile-char-to-text [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] @@ -356,6 +368,9 @@ "size" (compile-text-size compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) + "upper-case" (compile-text-upper-case compile ?values special-args) + "lower-case" (compile-text-lower-case compile ?values special-args) ) ;; "bit" diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 1cb4a6150..eaac37a6a 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1264,6 +1264,17 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textChar" (str "(function textChar(text,idx) {" + "var result = text.charAt(idx);" + (str "if(result === '') {" + (str "return " (make-some "result") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" + "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" + "})") }) (def LuxRT "LuxRT") diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index e75e09f1b..cfbaf3810 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -19,7 +19,8 @@ (:import (java.io File BufferedOutputStream FileOutputStream) - (java.lang.reflect Field))) + (java.lang.reflect Field) + )) ;; [Utils] (defn ^:private read-file [^File file] @@ -30,12 +31,6 @@ (.read reader buffer 0 length) buffer))) -(defn ^:private clean-file [^File file] - "(-> File (,))" - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - (defn ^:private get-field [^String field-name ^Class class] "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) @@ -43,20 +38,24 @@ ;; [Resources] (def module-class-file (str &/module-class-name ".class")) +(defn ^:private delete-all-module-files [^File file] + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private module-path [module] + (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) + (defn cached? [module] "(-> Text Bool)" - (.exists (new File (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator) - java.io.File/separator - module-class-file)))) + (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) (defn delete [module] "(-> Text (Lux Null))" (fn [state] - (do (clean-file (new File (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator)))) + (do (delete-all-module-files (new File (module-path module))) (return* state nil)))) (defn ^:private module-dirs @@ -85,30 +84,19 @@ corrected-dir-module))) (filter outdated?))] (doseq [^String f outdated-modules] - (clean-file (new File (str output-dir-prefix f)))) + (delete-all-module-files (new File (str output-dir-prefix f)))) nil)) -(defn ^:private install-all-classes-in-module [!classes module* ^String module-path] - (let [classes+bytecode (for [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= module-class-file file-name)] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[class-name bytecode] classes+bytecode] - (swap! !classes assoc (str module* "." class-name) bytecode))] - (map first classes+bytecode))) - -(defn ^:private assume-async-result - "(-> (Error Compiler) (Lux Null))" - [result] - (fn [_] - (|case result - (&/$Left error) - (&/$Left error) - - (&/$Right compiler) - (return* compiler nil)))) +(defn ^:private install-all-defs-in-module [!classes module* ^String module-path] + (let [file-name+content (for [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= module-class-file file-name)] + [(second (re-find #"^(.*)\.class$" file-name)) + (read-file file)]) + _ (doseq [[file-name content] file-name+content] + (swap! !classes assoc (str module* "." file-name) content))] + (map first file-name+content))) (defn ^:private parse-tag-groups [^String tags-section] (if (= "" tags-section) @@ -225,7 +213,7 @@ class-name (str module* "." &/module-class-name) ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) (&&/load-class! loader class-name)) - installed-classes (install-all-classes-in-module !classes module* module-path) + installed-classes (install-all-defs-in-module !classes module* module-path) valid-cache? (and (= module-hash (get-field &/hash-field module-class)) (= &/compiler-version (get-field &/compiler-field module-class))) drop-cache! (|do [_ (uninstall-cache module) @@ -240,7 +228,7 @@ (return cache-table*)) drop-cache!)))) -(def !pre-loaded-cache (atom nil)) +(def ^:private !pre-loaded-cache (atom nil)) (defn pre-load-cache! [source-dirs] (|do [:let [fs-cached-modules (enumerate-cached-modules!)] pre-loaded-modules (&/fold% (fn [cache-table module-name] diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj index 64760bbb6..12a2f83c7 100644 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -283,8 +283,6 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version class-flags current-class nil &&/function-class (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] @@ -353,8 +351,6 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version class-flags current-class nil "java/lang/Object" (into-array String [])) - (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) (-> (.visitField field-flags &/value-field datum-sig nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] -- cgit v1.2.3 From 71d7ff61aa914e153965a4ef6a7ae72b4fb54581 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 17 Feb 2017 22:40:06 -0400 Subject: - Added support for the new common procedures to the JVM backend. - Fixed some bugs. --- luxc/src/lux/compiler/jvm/proc/common.clj | 105 ++++++++++++++++++++++++------ luxc/src/lux/compiler/jvm/rt.clj | 102 ++++++++++++++++++++++------- 2 files changed, 161 insertions(+), 46 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index c48403e52..01048fd98 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,16 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "doubleToRawLongBits" "(D)J") + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -328,8 +338,18 @@ ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + ^:private compile-int-min-value (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long + ^:private compile-int-max-value (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long + ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-real-min-value (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double + ^:private compile-real-max-value (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double + + ^:private compile-real-not-a-number (.visitLdcInsn Double/NaN) &&/wrap-double + ^:private compile-real-positive-infinity (.visitLdcInsn Double/POSITIVE_INFINITY) &&/wrap-double + ^:private compile-real-negative-infinity (.visitLdcInsn Double/NEGATIVE_INFINITY) &&/wrap-double ) (do-template [ ] @@ -356,23 +376,34 @@ ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg" ) -(defn ^:private compile-int-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]] - (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "toString" ))]] + (return nil))) + + ^:private compile-int-encode "java/lang/Long" "(J)Ljava/lang/String;" &&/unwrap-long + ^:private compile-real-encode "java/lang/Double" "(D)Ljava/lang/String;" &&/unwrap-double + ) -(defn ^:private compile-real-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-double - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]] - (return nil))) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(Ljava/lang/String;)[Ljava/lang/Object;"))]] + (return nil))) + + ^:private compile-int-decode "decode_int" + ^:private compile-real-decode "decode_real" + ) (do-template [ ] (defn [compile ?values special-args] @@ -565,13 +596,32 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) -(defn ^:private compile-text-trim [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "()Ljava/lang/String;"))]] + (return nil))) + + ^:private compile-text-trim "trim" + ^:private compile-text-upper-case "toUpperCase" + ^:private compile-text-lower-case "toLowerCase" + ) + +(defn ^:private compile-text-char [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "trim" "()Ljava/lang/String;"))]] + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?idx) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) (defn compile-io-log [compile ?values special-args] @@ -620,6 +670,9 @@ "size" (compile-text-size compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "upper-case" (compile-text-upper-case compile ?values special-args) + "lower-case" (compile-text-lower-case compile ?values special-args) + "char" (compile-text-char compile ?values special-args) ) "bit" @@ -683,9 +736,12 @@ "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) + "max-value" (compile-int-max-value compile ?values special-args) + "min-value" (compile-int-min-value compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) "to-real" (compile-int-to-real compile ?values special-args) "encode" (compile-int-encode compile ?values special-args) + "decode" (compile-int-decode compile ?values special-args) ) "real" @@ -697,9 +753,16 @@ "%" (compile-real-rem compile ?values special-args) "=" (compile-real-eq compile ?values special-args) "<" (compile-real-lt compile ?values special-args) - "encode" (compile-real-encode compile ?values special-args) + "hash" (compile-real-hash compile ?values special-args) + "max-value" (compile-real-max-value compile ?values special-args) + "min-value" (compile-real-min-value compile ?values special-args) + "not-a-number" (compile-real-not-a-number compile ?values special-args) + "positive-infinity" (compile-real-positive-infinity compile ?values special-args) + "negative-infinity" (compile-real-negative-infinity compile ?values special-args) "to-int" (compile-real-to-int compile ?values special-args) "to-deg" (compile-real-to-deg compile ?values special-args) + "encode" (compile-real-encode compile ?values special-args) + "decode" (compile-real-decode compile ?values special-args) ) "char" diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 303d9ae0a..7f193a1cd 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1160,6 +1160,34 @@ (.visitEnd)))] nil))) +(do-template [ ] + (defn [^ClassWriter =class] + (do (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "(Ljava/lang/String;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC ) + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) + + ^:private compile-LuxRT-int-methods "decode_int" "java/lang/Long" "parseLong" "(Ljava/lang/String;)J" &&/wrap-long + ^:private compile-LuxRT-real-methods "decode_real" "java/lang/Double" "parseDouble" "(Ljava/lang/String;)D" &&/wrap-double + ) + (defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class] (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) (.visitCode) @@ -1205,31 +1233,53 @@ nil)) (defn ^:private compile-LuxRT-text-methods [^ClassWriter =class] - (|do [:let [_ (let [$from (new Label) - $to (new Label) - $handler (new Label) - $end (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") - (.visitLabel $from) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitVarInsn Opcodes/ILOAD 2) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $to) - (.visitLabel $handler) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))]] - (return nil))) + (do (let [$from (new Label) + $to (new Label) + $handler (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitVarInsn Opcodes/ILOAD 2) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ILOAD 1) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") + &&/wrap-char + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) (def compile-LuxRT-class (|do [_ (return nil) @@ -1291,7 +1341,9 @@ (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) (compile-LuxRT-nat-methods) + (compile-LuxRT-int-methods) (compile-LuxRT-deg-methods) + (compile-LuxRT-real-methods) (compile-LuxRT-text-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) -- cgit v1.2.3 From 4e980a83d5e7532ed58337658c0631e2282c969f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Feb 2017 18:22:27 -0400 Subject: - Now storing the compiler's version and the module-file's hash inside the module-descriptor, instead of .class files (to make it reusable across different compiler targets). --- luxc/src/lux/base.clj | 2 -- luxc/src/lux/compiler/core.clj | 6 ++++-- luxc/src/lux/compiler/js.clj | 2 +- luxc/src/lux/compiler/jvm.clj | 6 +----- luxc/src/lux/compiler/jvm/cache.clj | 34 ++++++++++++++++++---------------- 5 files changed, 24 insertions(+), 26 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 1a9fadf63..bbb5f3888 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -220,9 +220,7 @@ ("DictA" 1)) ;; [Exports] -(def ^:const hash-field "_hash") (def ^:const value-field "_value") -(def ^:const compiler-field "_compiler") (def ^:const eval-field "_eval") (def ^:const module-class-name "_") (def ^:const +name-separator+ ";") diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj index 4779c3c28..6dacb4e54 100644 --- a/luxc/src/lux/compiler/core.clj +++ b/luxc/src/lux/compiler/core.clj @@ -44,7 +44,7 @@ (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) :encoding "UTF-8")))) -(def generate-module-descriptor +(defn generate-module-descriptor [file-hash] (|do [module-name &/get-module-name module-anns (&a-module/get-anns module-name) defs &a-module/defs @@ -73,7 +73,9 @@ (str type datum-separator))))) (&/|interpose entry-separator) (&/fold str "")) - module-descriptor (->> (&/|list import-entries + module-descriptor (->> (&/|list &/compiler-version + (Long/toUnsignedString file-hash) + import-entries tag-entries (&&&ann/serialize-anns module-anns) def-entries) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 5bb97728f..b17c06436 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -151,7 +151,7 @@ (&/$Right ?state _) (&/run-state (|do [_ (&a-module/flag-compiled-module name) ;; _ (&&/save-class! &/module-class-name (.toByteArray =class)) - module-descriptor &&core/generate-module-descriptor + module-descriptor (&&core/generate-module-descriptor file-hash) _ (&&core/write-module-descriptor! name module-descriptor)] (return file-hash)) ?state) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index d0d3c1bc3..68dcb0306 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -188,10 +188,6 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) module-class-name nil "java/lang/Object" nil) - (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash) - .visitEnd) - (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version) - .visitEnd) (.visitSource file-name nil))] _ (if (= "lux" name) (|do [_ &&rt/compile-Function-class @@ -206,7 +202,7 @@ (&/run-state (|do [:let [_ (.visitEnd =class)] _ (&a-module/flag-compiled-module name) _ (&&/save-class! &/module-class-name (.toByteArray =class)) - module-descriptor &&core/generate-module-descriptor + module-descriptor (&&core/generate-module-descriptor file-hash) _ (&&core/write-module-descriptor! name module-descriptor)] (return file-hash)) ?state) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index cfbaf3810..b2b4f2bac 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -145,10 +145,10 @@ _ (&/map% (partial process-tag-group module) tag-groups)] (return nil))) -(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader] +(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader + _imports-section _tags-section _module-anns-section _defs-section] (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [[imports-section tags-section module-anns-section defs-section] (.split descriptor &&core/section-separator) - imports (let [imports (vec (.split ^String imports-section &&core/entry-separator)) + :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) imports (if (= [""] imports) &/$Nil (&/->list imports))] @@ -164,9 +164,9 @@ (|let [[_module _hash] _import] (contains? cache-table* _module))) imports) - (let [tag-groups (parse-tag-groups tags-section) - module-anns (&&&ann/deserialize-anns module-anns-section) - def-entries (let [def-entries (vec (.split ^String defs-section &&core/entry-separator))] + (let [tag-groups (parse-tag-groups _tags-section) + module-anns (&&&ann/deserialize-anns _module-anns-section) + def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] (if (= [""] def-entries) &/$Nil (&/->list def-entries)))] @@ -198,30 +198,32 @@ (.substring prefix-to-subtract))) &/->list))) -(defn ^:private pre-load! [source-dirs cache-table module module-hash] - (cond (contains? cache-table module) +(defn ^:private pre-load! [source-dirs cache-table module-name module-hash] + (cond (contains? cache-table module-name) (return cache-table) - (not (cached? module)) + (not (cached? module-name)) (return cache-table) :else (|do [loader &/loader !classes &/classes - :let [module* (&host-generics/->class-name module) - module-path (str @&&core/!output-dir java.io.File/separator module) + ^String descriptor (&&core/read-module-descriptor! module-name) + :let [module* (&host-generics/->class-name module-name) + module-path (str @&&core/!output-dir java.io.File/separator module-name) class-name (str module* "." &/module-class-name) ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) (&&/load-class! loader class-name)) installed-classes (install-all-defs-in-module !classes module* module-path) - valid-cache? (and (= module-hash (get-field &/hash-field module-class)) - (= &/compiler-version (get-field &/compiler-field module-class))) - drop-cache! (|do [_ (uninstall-cache module) + [_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) + drop-cache! (|do [_ (uninstall-cache module-name) :let [_ (swap! !classes (fn [_classes-dict] (reduce dissoc _classes-dict installed-classes)))]] (return cache-table))]] - (if valid-cache? - (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module module-hash loader) + (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) + (= &/compiler-version _compiler)) + (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash loader + _imports-section _tags-section _module-anns-section _defs-section) _ (if success? (return nil) drop-cache!)] -- cgit v1.2.3 From 58f274ae34835d27cd17add767f6fbef13aef7c5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 19 Feb 2017 23:44:03 -0400 Subject: - Separated the platform-independent and platform-dependent components of the caching mechanism. --- luxc/src/lux/compiler/cache.clj | 230 +++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm.clj | 10 +- luxc/src/lux/compiler/jvm/cache.clj | 263 +++++------------------------------- luxc/src/lux/repl.clj | 8 +- 4 files changed, 273 insertions(+), 238 deletions(-) create mode 100644 luxc/src/lux/compiler/cache.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj new file mode 100644 index 000000000..09b688832 --- /dev/null +++ b/luxc/src/lux/compiler/cache.clj @@ -0,0 +1,230 @@ +(ns lux.compiler.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [host :as &host]) + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [core :as &&core] + [io :as &&io]) + (lux.compiler.cache [type :as &&&type] + [ann :as &&&ann])) + (:import (java.io File) + )) + +;; [Resources] +(defn ^:private delete-all-module-files [^File file] + (doseq [^File f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) + +(defn ^:private module-path [module] + (str @&&core/!output-dir + java.io.File/separator + (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) + +(defn cached? [module] + "(-> Text Bool)" + (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) + +(defn delete [module] + "(-> Text (Lux Null))" + (fn [state] + (do (delete-all-module-files (new File (module-path module))) + (return* state nil)))) + +(defn ^:private module-dirs + "(-> File (clojure.Seq File))" + [^File module] + (->> module + .listFiles + (filter #(.isDirectory ^File %)) + (map module-dirs) + (apply concat) + (list* module))) + +(defn clean [state] + "(-> Compiler Null)" + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) + outdated? #(->> % (contains? needed-modules) not) + outdated-modules (->> (new File ^String @&&core/!output-dir) + .listFiles (filter #(.isDirectory ^File %)) + (map module-dirs) doall (apply concat) + (map (fn [^File dir-file] + (let [^String dir-module (-> dir-file + .getAbsolutePath + (string/replace output-dir-prefix "")) + corrected-dir-module (.replace dir-module java.io.File/separator "/")] + corrected-dir-module))) + (filter outdated?))] + (doseq [^String f outdated-modules] + (delete-all-module-files (new File (str output-dir-prefix f)))) + nil)) + +(defn ^:private parse-tag-groups [^String tags-section] + (if (= "" tags-section) + &/$Nil + (-> tags-section + (.split &&core/entry-separator) + seq + (->> (map (fn [^String _group] + (let [[_type & _tags] (.split _group &&core/datum-separator)] + (&/T [_type (->> _tags seq &/->list)]))))) + &/->list))) + +(defn ^:private process-tag-group [module group] + (|let [[_type _tags] group] + (|do [[was-exported? =type] (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags was-exported? =type)))) + +(defn ^:private process-def-entry [load-def-value module ^String _def-entry] + (let [parts (.split _def-entry &&core/datum-separator)] + (case (alength parts) + 2 (let [[_name _alias] parts + [_ __module __name] (re-find #"^(.*);(.*)$" _alias) + def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))]))] + (|do [def-type (&a-module/def-type __module __name) + def-value (load-def-value __module __name)] + (&a-module/define module _name def-type def-anns def-value))) + 3 (let [[_name _type _anns] parts + def-anns (&&&ann/deserialize-anns _anns) + [def-type _] (&&&type/deserialize-type _type)] + (|do [def-value (load-def-value module _name)] + (&a-module/define module _name def-type def-anns def-value)))))) + +(defn ^:private uninstall-cache [module] + (|do [_ (delete module)] + (return false))) + +(defn ^:private install-module [load-def-value module module-hash imports tag-groups module-anns def-entries] + (|do [_ (&a-module/create-module module module-hash) + _ (&a-module/flag-cached-module module) + _ (&a-module/set-anns module-anns module) + _ (&a-module/set-imports imports) + _ (&/map% (partial process-def-entry load-def-value module) + def-entries) + _ (&/map% (partial process-tag-group module) tag-groups)] + (return nil))) + +(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash + _imports-section _tags-section _module-anns-section _defs-section + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (|do [^String descriptor (&&core/read-module-descriptor! module-name) + :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) + imports (if (= [""] imports) + &/$Nil + (&/->list imports))] + (&/|map #(.split ^String % &&core/datum-separator 2) imports))] + cache-table* (&/fold% (fn [cache-table* _import] + (|do [:let [[_module _hash] _import] + file-content (&&io/read-file source-dirs (str _module ".lux")) + output (pre-load! source-dirs cache-table* _module (hash file-content) + load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] + (return output))) + cache-table + imports)] + (if (&/|every? (fn [_import] + (|let [[_module _hash] _import] + (contains? cache-table* _module))) + imports) + (let [tag-groups (parse-tag-groups _tags-section) + module-anns (&&&ann/deserialize-anns _module-anns-section) + def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] + (if (= [""] def-entries) + &/$Nil + (&/->list def-entries)))] + (|do [_ (install-module load-def-value module-name module-hash + imports tag-groups module-anns def-entries) + =module (&/find-module module-name)] + (return (&/T [true (assoc cache-table* module-name =module)])))) + (return (&/T [false cache-table*]))))) + +(defn ^:private enumerate-cached-modules!* [^File parent] + (if (.isDirectory parent) + (let [children (for [^File child (seq (.listFiles parent)) + entry (enumerate-cached-modules!* child)] + entry)] + (if (.exists (new File parent "_.class")) + (list* (.getAbsolutePath parent) + children) + children)) + (list))) + +(defn ^:private enumerate-cached-modules! [] + (let [output-dir (new File ^String @&&core/!output-dir) + prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] + (->> output-dir + enumerate-cached-modules!* + rest + (map #(-> ^String % + (.replace java.io.File/separator "/") + (.substring prefix-to-subtract))) + &/->list))) + +(defn ^:private pre-load! [source-dirs cache-table module-name module-hash + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (cond (contains? cache-table module-name) + (return cache-table) + + (not (cached? module-name)) + (return cache-table) + + :else + (|do [^String descriptor (&&core/read-module-descriptor! module-name) + installed-classes (install-all-defs-in-module module-name) + :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) + drop-cache! (|do [_ (uninstall-cache module-name) + _ (uninstall-all-defs-in-module module-name)] + (return cache-table))]] + (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) + (= &/compiler-version _compiler)) + (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash + _imports-section _tags-section _module-anns-section _defs-section + load-def-value install-all-defs-in-module uninstall-all-defs-in-module) + _ (if success? + (return nil) + drop-cache!)] + (return cache-table*)) + drop-cache!)))) + +(def ^:private !pre-loaded-cache (atom nil)) +(defn pre-load-cache! [source-dirs + load-def-value install-all-defs-in-module uninstall-all-defs-in-module] + (|do [:let [fs-cached-modules (enumerate-cached-modules!)] + pre-loaded-modules (&/fold% (fn [cache-table module-name] + (fn [_compiler] + (|case ((&&io/read-file source-dirs (str module-name ".lux")) + _compiler) + (&/$Left error) + (return* _compiler cache-table) + + (&/$Right _compiler* file-content) + ((pre-load! source-dirs cache-table module-name (hash file-content) + load-def-value install-all-defs-in-module uninstall-all-defs-in-module) + _compiler*)))) + {} + fs-cached-modules) + :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] + (return nil))) + +(defn ^:private inject-module + "(-> (Module Compiler) (-> Compiler (Lux Null)))" + [module-name module] + (fn [compiler] + (return* (&/update$ &/$modules + #(&/|put module-name module %) + compiler) + nil))) + +(defn load [module-name] + "(-> Text (Lux Null))" + (if-let [module-struct (get @!pre-loaded-cache module-name)] + (|do [_ (inject-module module-name module-struct)] + (return nil)) + (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 68dcb0306..f09224c90 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -19,13 +19,14 @@ [lux.analyser.module :as &a-module] (lux.compiler [core :as &&core] [io :as &&io] + [cache :as &&cache] [parallel :as &¶llel]) (lux.compiler.jvm [base :as &&] - [cache :as &&cache] [lux :as &&lux] [case :as &&case] [lambda :as &&lambda] - [rt :as &&rt]) + [rt :as &&rt] + [cache :as &&jvm-cache]) (lux.compiler.jvm.proc [common :as &&proc-common] [host :as &&proc-host])) (:import (org.objectweb.asm Opcodes @@ -243,7 +244,10 @@ (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] - (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs) + (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs + &&jvm-cache/load-def-value + &&jvm-cache/install-all-defs-in-module + &&jvm-cache/uninstall-all-defs-in-module) _ (compile-module source-dirs "lux")] (compile-module source-dirs program-module))] (|case (m-action (&/init-state mode (jvm-host))) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index b2b4f2bac..c6549a718 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -13,12 +13,8 @@ [meta :as &a-meta]) (lux.compiler [core :as &&core] [io :as &&io]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann]) (lux.compiler.jvm [base :as &&])) - (:import (java.io File - BufferedOutputStream - FileOutputStream) + (:import (java.io File) (java.lang.reflect Field) )) @@ -35,231 +31,36 @@ "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) -;; [Resources] -(def module-class-file (str &/module-class-name ".class")) - -(defn ^:private delete-all-module-files [^File file] - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - -(defn ^:private module-path [module] - (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) - -(defn cached? [module] - "(-> Text Bool)" - (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) - -(defn delete [module] - "(-> Text (Lux Null))" - (fn [state] - (do (delete-all-module-files (new File (module-path module))) - (return* state nil)))) - -(defn ^:private module-dirs - "(-> File (clojure.Seq File))" - [^File module] - (->> module - .listFiles - (filter #(.isDirectory ^File %)) - (map module-dirs) - (apply concat) - (list* module))) - -(defn clean [state] - "(-> Compiler Null)" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) - output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) - outdated? #(->> % (contains? needed-modules) not) - outdated-modules (->> (new File ^String @&&core/!output-dir) - .listFiles (filter #(.isDirectory ^File %)) - (map module-dirs) doall (apply concat) - (map (fn [^File dir-file] - (let [^String dir-module (-> dir-file - .getAbsolutePath - (string/replace output-dir-prefix "")) - corrected-dir-module (.replace dir-module java.io.File/separator "/")] - corrected-dir-module))) - (filter outdated?))] - (doseq [^String f outdated-modules] - (delete-all-module-files (new File (str output-dir-prefix f)))) - nil)) - -(defn ^:private install-all-defs-in-module [!classes module* ^String module-path] - (let [file-name+content (for [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= module-class-file file-name)] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[file-name content] file-name+content] - (swap! !classes assoc (str module* "." file-name) content))] - (map first file-name+content))) - -(defn ^:private parse-tag-groups [^String tags-section] - (if (= "" tags-section) - &/$Nil - (-> tags-section - (.split &&core/entry-separator) - seq - (->> (map (fn [^String _group] - (let [[_type & _tags] (.split _group &&core/datum-separator)] - (&/T [_type (->> _tags seq &/->list)]))))) - &/->list))) - -(defn ^:private process-tag-group [module group] - (|let [[_type _tags] group] - (|do [[was-exported? =type] (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags was-exported? =type)))) - -(defn ^:private process-def-entry [loader module ^String _def-entry] - (let [parts (.split _def-entry &&core/datum-separator)] - (case (alength parts) - 2 (let [[_name _alias] parts - [_ __module __name] (re-find #"^(.*);(.*)$" _alias) - def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name))) - def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))])) - def-value (get-field &/value-field def-class)] - (|do [def-type (&a-module/def-type __module __name)] - (&a-module/define module _name def-type def-anns def-value))) - 3 (let [[_name _type _anns] parts - def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name _name))) - def-anns (&&&ann/deserialize-anns _anns) - [def-type _] (&&&type/deserialize-type _type) - def-value (get-field &/value-field def-class)] - (&a-module/define module _name def-type def-anns def-value))))) - -(defn ^:private uninstall-cache [module] - (|do [_ (delete module)] - (return false))) +(def ^:private module-class-file (str &/module-class-name ".class")) -(defn ^:private install-module [loader module module-hash imports tag-groups module-anns def-entries] - (|do [_ (&a-module/create-module module module-hash) - _ (&a-module/flag-cached-module module) - _ (&a-module/set-anns module-anns module) - _ (&a-module/set-imports imports) - _ (&/map% (partial process-def-entry loader module) - def-entries) - _ (&/map% (partial process-tag-group module) tag-groups)] - (return nil))) - -(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader - _imports-section _tags-section _module-anns-section _defs-section] - (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) - imports (if (= [""] imports) - &/$Nil - (&/->list imports))] - (&/|map #(.split ^String % &&core/datum-separator 2) imports))] - cache-table* (&/fold% (fn [cache-table* _import] - (|do [:let [[_module _hash] _import] - file-content (&&io/read-file source-dirs (str _module ".lux")) - output (pre-load! source-dirs cache-table* _module (hash file-content))] - (return output))) - cache-table - imports)] - (if (&/|every? (fn [_import] - (|let [[_module _hash] _import] - (contains? cache-table* _module))) - imports) - (let [tag-groups (parse-tag-groups _tags-section) - module-anns (&&&ann/deserialize-anns _module-anns-section) - def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] - (if (= [""] def-entries) - &/$Nil - (&/->list def-entries)))] - (|do [_ (install-module loader module-name module-hash - imports tag-groups module-anns def-entries) - =module (&/find-module module-name)] - (return (&/T [true (assoc cache-table* module-name =module)])))) - (return (&/T [false cache-table*]))))) - -(defn ^:private enumerate-cached-modules!* [^File parent] - (if (.isDirectory parent) - (let [children (for [^File child (seq (.listFiles parent)) - entry (enumerate-cached-modules!* child)] - entry)] - (if (.exists (new File parent "_.class")) - (list* (.getAbsolutePath parent) - children) - children)) - (list))) - -(defn ^:private enumerate-cached-modules! [] - (let [output-dir (new File ^String @&&core/!output-dir) - prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] - (->> output-dir - enumerate-cached-modules!* - rest - (map #(-> ^String % - (.replace java.io.File/separator "/") - (.substring prefix-to-subtract))) - &/->list))) - -(defn ^:private pre-load! [source-dirs cache-table module-name module-hash] - (cond (contains? cache-table module-name) - (return cache-table) - - (not (cached? module-name)) - (return cache-table) - - :else - (|do [loader &/loader - !classes &/classes - ^String descriptor (&&core/read-module-descriptor! module-name) - :let [module* (&host-generics/->class-name module-name) - module-path (str @&&core/!output-dir java.io.File/separator module-name) - class-name (str module* "." &/module-class-name) - ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file)))) - (&&/load-class! loader class-name)) - installed-classes (install-all-defs-in-module !classes module* module-path) - [_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) - drop-cache! (|do [_ (uninstall-cache module-name) - :let [_ (swap! !classes (fn [_classes-dict] - (reduce dissoc _classes-dict installed-classes)))]] - (return cache-table))]] - (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) - (= &/compiler-version _compiler)) - (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash loader - _imports-section _tags-section _module-anns-section _defs-section) - _ (if success? - (return nil) - drop-cache!)] - (return cache-table*)) - drop-cache!)))) - -(def ^:private !pre-loaded-cache (atom nil)) -(defn pre-load-cache! [source-dirs] - (|do [:let [fs-cached-modules (enumerate-cached-modules!)] - pre-loaded-modules (&/fold% (fn [cache-table module-name] - (fn [_compiler] - (|case ((&&io/read-file source-dirs (str module-name ".lux")) - _compiler) - (&/$Left error) - (return* _compiler cache-table) - - (&/$Right _compiler* file-content) - ((pre-load! source-dirs cache-table module-name (hash file-content)) - _compiler*)))) - {} - fs-cached-modules) - :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] +;; [Resources] +(defn load-def-value [module name] + (|do [loader &/loader + :let [def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name name)))]] + (return (get-field &/value-field def-class)))) + +(defn install-all-defs-in-module [module-name] + (|do [!classes &/classes + :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) + file-name+content (for [^File file (seq (.listFiles (new File module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)]] + [(second (re-find #"^(.*)\.class$" file-name)) + (read-file file)]) + _ (doseq [[file-name content] file-name+content] + (swap! !classes assoc (str (&host-generics/->class-name module-name) + "." + file-name) + content))]] + (return (map first file-name+content)))) + +(defn uninstall-all-defs-in-module [module-name] + (|do [!classes &/classes + :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) + installed-files (for [^File file (seq (.listFiles (new File module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)]] + (second (re-find #"^(.*)\.class$" file-name))) + _ (swap! !classes (fn [_classes-dict] + (reduce dissoc _classes-dict installed-files)))]] (return nil))) - -(defn ^:private inject-module - "(-> (Module Compiler) (-> Compiler (Lux Null)))" - [module-name module] - (fn [compiler] - (return* (&/update$ &/$modules - #(&/|put module-name module %) - compiler) - nil))) - -(defn load [module-name] - "(-> Text (Lux Null))" - (if-let [module-struct (get @!pre-loaded-cache module-name)] - (|do [_ (inject-module module-name module-struct)] - (return nil)) - (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj index 7562aaf70..974267486 100644 --- a/luxc/src/lux/repl.clj +++ b/luxc/src/lux/repl.clj @@ -6,10 +6,10 @@ [analyser :as &analyser] [optimizer :as &optimizer] [compiler :as &compiler]) - [lux.compiler.jvm.cache :as &cache] - [lux.analyser.base :as &a-base] - [lux.analyser.lux :as &a-lux] - [lux.analyser.module :as &module]) + [lux.compiler.cache :as &cache] + (lux.analyser [base :as &a-base] + [lux :as &a-lux] + [module :as &module])) (:import (java.io InputStreamReader BufferedReader))) -- cgit v1.2.3 From c15092022b484eaf52a34bd3ac1bec2ecf15efd9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 20 Feb 2017 18:51:39 -0400 Subject: - Some minor refactoring. --- luxc/src/lux/compiler/js/base.clj | 6 ++++++ luxc/src/lux/compiler/js/lux.clj | 14 ++++---------- luxc/src/lux/compiler/jvm/cache.clj | 2 -- 3 files changed, 10 insertions(+), 12 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 044a4f099..fcf8a248c 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -195,3 +195,9 @@ (do (.mkdirs (File. module-dir)) (&&/write-file (str module-dir java.io.File/separator (&host/def-name name) ".js") (.getBytes script)))))]] (return nil))) + +(defn js-module [module] + (string/replace module "/" "$")) + +(defn js-var-name [module name] + (str (js-module module) "$" (&host/def-name name))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 39f943dda..0f86d8a33 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -19,12 +19,6 @@ )) ;; [Utils] -(defn ^:private js-module [module] - (string/replace module "/" "$")) - -(defn ^:private js-var-name [module name] - (str (js-module module) "$" (&host/def-name name))) - (defn ^:private captured-name [register] (str "$" register)) @@ -84,7 +78,7 @@ (return (captured-name ?captured-id))) (defn compile-global [module name] - (return (js-var-name module name))) + (return (&&/js-var-name module name))) (defn compile-apply [compile ?fn ?args] (|do [=fn (compile ?fn) @@ -276,7 +270,7 @@ (defn compile-function [compile arity ?scope ?env ?body] (|do [:let [??scope (&/|reverse ?scope) - function-name (str (js-module (&/|head ??scope)) + function-name (str (&&/js-module (&/|head ??scope)) "$" (&host/location (&/|tail ??scope))) func-args (->> (&/|range* 0 (dec arity)) (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) @@ -325,7 +319,7 @@ (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) (&/$Some (&/$IdentA [r-module r-name])) (if (= 1 (&/|length def-meta)) - (|do [def-value (&&/run-js! (js-var-name r-module r-name)) + (|do [def-value (&&/run-js! (&&/js-var-name r-module r-name)) def-type (&a-module/def-type r-module r-name) _ (&/without-repl-closure (&a-module/define module-name ?name def-type def-meta def-value))] @@ -336,7 +330,7 @@ (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") _ - (|do [:let [var-name (js-var-name module-name ?name)] + (|do [:let [var-name (&&/js-var-name module-name ?name)] =body (compile ?body) :let [def-js (str "var " var-name " = " =body ";") is-type? (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj index c6549a718..a42c7afdd 100644 --- a/luxc/src/lux/compiler/jvm/cache.clj +++ b/luxc/src/lux/compiler/jvm/cache.clj @@ -31,8 +31,6 @@ "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) -(def ^:private module-class-file (str &/module-class-name ".class")) - ;; [Resources] (defn load-def-value [module name] (|do [loader &/loader -- cgit v1.2.3 From 0bfb1b4b1431c51441e4b47160e8c7dc8109da1b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 20 Feb 2017 19:51:03 -0400 Subject: - Changed the order the cache is loaded. --- luxc/src/lux/compiler/cache.clj | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj index 09b688832..77e4221e8 100644 --- a/luxc/src/lux/compiler/cache.clj +++ b/luxc/src/lux/compiler/cache.clj @@ -139,7 +139,8 @@ (if (= [""] def-entries) &/$Nil (&/->list def-entries)))] - (|do [_ (install-module load-def-value module-name module-hash + (|do [_ (install-all-defs-in-module module-name) + _ (install-module load-def-value module-name module-hash imports tag-groups module-anns def-entries) =module (&/find-module module-name)] (return (&/T [true (assoc cache-table* module-name =module)])))) @@ -150,7 +151,7 @@ (let [children (for [^File child (seq (.listFiles parent)) entry (enumerate-cached-modules!* child)] entry)] - (if (.exists (new File parent "_.class")) + (if (.exists (new File parent &&core/lux-module-descriptor-name)) (list* (.getAbsolutePath parent) children) children)) @@ -177,7 +178,6 @@ :else (|do [^String descriptor (&&core/read-module-descriptor! module-name) - installed-classes (install-all-defs-in-module module-name) :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator) drop-cache! (|do [_ (uninstall-cache module-name) _ (uninstall-all-defs-in-module module-name)] -- cgit v1.2.3 From db5dcef3d2a5d3d786617a379a106bd66de3082f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 20 Feb 2017 19:51:46 -0400 Subject: - Now saving all the JS in a single file, instead of multiple files. --- luxc/src/lux/compiler/js/base.clj | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index fcf8a248c..50ece15e6 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -30,6 +30,28 @@ &/$None ])) +(def ^String module-js-name "module.js") + +(def init-buffer + (fn [compiler-state] + (&/$Right (&/T [(&/update$ &/$host + (fn [host] + (&/set$ $buffer + (&/$Some (new StringBuilder)) + host)) + compiler-state) + nil])))) + +(def get-buffer + (fn [compiler-state] + (|case (->> compiler-state (&/get$ &/$host) (&/get$ $buffer)) + (&/$Some _buffer) + (&/$Right (&/T [compiler-state + _buffer])) + + (&/$None) + (&/$Left "[Error] No buffer available.")))) + (defn run-js! [^String js-code] (fn [compiler-state] (|let [^NashornScriptEngine interpreter (->> compiler-state (&/get$ &/$host) (&/get$ $interpreter))] @@ -189,11 +211,21 @@ (|do [_ (run-js! script) eval? &/get-eval module &/get-module-name + ^StringBuilder buffer get-buffer + :let [_ (when (not eval?) + (.append buffer ^String (str script "\n")))]] + (return nil))) + +(def save-module-js! + (|do [eval? &/get-eval + module &/get-module-name + ^StringBuilder buffer get-buffer :let [_ (when (not eval?) (let [^String module* (&host/->module-class module) module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] (do (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator (&host/def-name name) ".js") (.getBytes script)))))]] + (&&/write-file (str module-dir java.io.File/separator module-js-name) + (.getBytes (.toString buffer))))))]] (return nil))) (defn js-module [module] -- cgit v1.2.3 From 22b50868848f757b7f03fbd423ed3620ded52273 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 20 Feb 2017 19:54:18 -0400 Subject: - Implemented caching mechanisms for JS. --- luxc/src/lux/compiler/js.clj | 66 +++++++++++++++++++------------------- luxc/src/lux/compiler/js/cache.clj | 40 +++++++++++++++++++++++ 2 files changed, 73 insertions(+), 33 deletions(-) create mode 100644 luxc/src/lux/compiler/js/cache.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index b17c06436..18b91f5bc 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -17,12 +17,12 @@ [lux.analyser.module :as &a-module] (lux.compiler [core :as &&core] [io :as &&io] - [parallel :as &¶llel]) + [parallel :as &¶llel] + [cache :as &&cache]) (lux.compiler.js [base :as &&] - ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - ) + [cache :as &&js-cache]) (lux.compiler.js.proc [common :as &&common]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory @@ -131,46 +131,46 @@ (|do [file-content (&&io/read-file source-dirs file-name) :let [file-hash (hash file-content) compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - ;; (&/|eitherL (&&cache/load name)) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) - (|do [;; _ (&&cache/delete name) - _ (&a-module/create-module name file-hash) - _ (&a-module/flag-active-module name) - _ (if (= "lux" name) - &&rt/compile-LuxRT - (return nil)) - ] - (fn [state] - (|case ((&/exhaust% compiler-step) - ;; (&/with-writer =class - ;; (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [_ (&a-module/flag-compiled-module name) - ;; _ (&&/save-class! &/module-class-name (.toByteArray =class)) - module-descriptor (&&core/generate-module-descriptor file-hash) - _ (&&core/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message)))))))) + (&/|eitherL (&&cache/load name) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) + (|do [_ (&&cache/delete name) + _ &&/init-buffer + _ (&a-module/create-module name file-hash) + _ (&a-module/flag-active-module name) + _ (if (= "lux" name) + &&rt/compile-LuxRT + (return nil))] + (fn [state] + (|case ((&/exhaust% compiler-step) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [_ (&a-module/flag-compiled-module name) + _ &&/save-module-js! + module-descriptor (&&core/generate-module-descriptor file-hash) + _ (&&core/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message))))))))) )) (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] (do (init! resources-dir target-dir) - (let [m-action (|do [;; _ (&&cache/pre-load-cache! source-dirs) + (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs + &&js-cache/load-def-value + &&js-cache/install-all-defs-in-module + &&js-cache/uninstall-all-defs-in-module) _ (compile-module source-dirs "lux")] (compile-module source-dirs program-module))] (|case (m-action (&/init-state mode (&&/js-host))) (&/$Right ?state _) (do (println "Compilation complete!") - ;; (&&cache/clean ?state) - ) + (&&cache/clean ?state)) (&/$Left ?message) (binding [*out* !err!] diff --git a/luxc/src/lux/compiler/js/cache.clj b/luxc/src/lux/compiler/js/cache.clj new file mode 100644 index 000000000..0945e6b5b --- /dev/null +++ b/luxc/src/lux/compiler/js/cache.clj @@ -0,0 +1,40 @@ +(ns lux.compiler.js.cache + (:refer-clojure :exclude [load]) + (:require [clojure.string :as string] + [clojure.java.io :as io] + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |case |let]] + [type :as &type] + [host :as &host]) + [lux.host.generics :as &host-generics] + (lux.analyser [base :as &a] + [module :as &a-module] + [meta :as &a-meta]) + (lux.compiler [core :as &&core] + [io :as &&io]) + (lux.compiler.js [base :as &&])) + (:import (java.io File))) + +;; [Utils] +(defn ^:private read-file [^File file] + "(-> File (Array Byte))" + (with-open [reader (io/input-stream file)] + (let [length (.length file) + buffer (byte-array length)] + (.read reader buffer 0 length) + buffer))) + +;; [Resources] +(defn load-def-value [module name] + (&&/run-js!+ (&&/js-var-name module name))) + +(defn install-all-defs-in-module [module-name] + (|do [:let [module-code-path (str @&&core/!output-dir java.io.File/separator module-name java.io.File/separator &&/module-js-name) + ^bytes module-code (read-file (new File module-code-path))] + _ (&&/run-js!+ (new String module-code))] + (return (&/|list)))) + +(defn uninstall-all-defs-in-module [module-name] + (|do [] + (return nil))) -- cgit v1.2.3 From b5783fba01f453f2c165baded5066637405baf2e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Feb 2017 18:33:43 -0400 Subject: - Made some optimizations. - Compiler can now distinguish between JVM and JS host state. - Now, complex (with subtyping) type-checking can be done only during JVM compilation. --- luxc/src/lux/analyser.clj | 2 +- luxc/src/lux/analyser/lux.clj | 54 ++++++----- luxc/src/lux/base.clj | 192 +++++++++++++++++++------------------- luxc/src/lux/compiler/cache.clj | 2 +- luxc/src/lux/compiler/core.clj | 4 +- luxc/src/lux/compiler/js.clj | 2 +- luxc/src/lux/compiler/js/base.clj | 49 ++++------ luxc/src/lux/compiler/js/lux.clj | 3 +- luxc/src/lux/compiler/jvm.clj | 32 +++---- luxc/src/lux/type.clj | 89 ++++++++++-------- 10 files changed, 212 insertions(+), 217 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index e2aa64590..280085777 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -57,7 +57,7 @@ (return (&&/|meta =output-type ?output-cursor ?output-term)))) )))) -(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token] +(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token] (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) [cursor token] ?token compile-def (aget compilers 0) diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index af7f0f3f9..aee46a9cc 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -376,35 +376,33 @@ ))))) (defn analyse-apply [analyse cursor exo-type macro-caller =fn ?args] - (|do [loader &/loader - :let [[[=fn-type =fn-cursor] =fn-form] =fn]] - (|case =fn-form - (&&/$var (&/$Global ?module ?name)) - (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] - (|case (&&meta/meta-get &&meta/macro?-tag ?meta) - (&/$Some _) - (|do [macro-expansion (fn [state] - (|case (macro-caller ?value ?args state) - (&/$Right state* output) - (&/$Right (&/T [state* output])) - - (&/$Left error) - ((&/fail-with-loc error) state))) - ;; module-name &/get-module-name - ;; :let [[r-prefix r-name] real-name - ;; _ (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) + (|case =fn + [_ (&&/$var (&/$Global ?module ?name))] + (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)] + (|case (&&meta/meta-get &&meta/macro?-tag ?meta) + (&/$Some _) + (|do [macro-expansion (fn [state] + (|case (macro-caller ?value ?args state) + (&/$Right state* output) + (&/$Right (&/T [state* output])) + + (&/$Left error) + ((&/fail-with-loc error) state))) + ;; module-name &/get-module-name + ;; :let [[r-prefix r-name] real-name + ;; _ (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))] + ] + (&/flat-map% (partial analyse exo-type) macro-expansion)) - _ - (do-analyse-apply analyse exo-type =fn ?args))) - - _ - (do-analyse-apply analyse exo-type =fn ?args)) - )) + _ + (do-analyse-apply analyse exo-type =fn ?args))) + + _ + (do-analyse-apply analyse exo-type =fn ?args)) + ) (defn analyse-case [analyse exo-type ?value ?branches] (|do [:let [num-branches (&/|length ?branches)] diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index bbb5f3888..df4fb293f 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -137,6 +137,11 @@ ["compiler-version" "compiler-mode"]) +;; Hosts +(defvariant + ("Jvm" 1) + ("Js" 1)) + (deftuple ["info" "source" @@ -221,7 +226,6 @@ ;; [Exports] (def ^:const value-field "_value") -(def ^:const eval-field "_eval") (def ^:const module-class-name "_") (def ^:const +name-separator+ ";") @@ -659,6 +663,18 @@ (return* state unit-tag) (fail* msg))))) +(defn |some [f xs] + "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" + (|case xs + ($Nil) + $None + + ($Cons x xs*) + (|case (f x) + ($None) (|some f xs*) + output output) + )) + (defn ^:private normalize-char [char] (case char \* "_ASTER_" @@ -690,10 +706,6 @@ (defn normalize-name [ident] (reduce str "" (map normalize-char ident))) -(def classes - (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) - (def +init-bindings+ (T [;; "lux;counter" 0 @@ -711,9 +723,85 @@ +init-bindings+] )) -(def loader - (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) +(do-template [ ] + (do (def + (fn [compiler] + (|case (get$ $host compiler) + ( host-data) + (return* compiler host-data) + + _ + (fail* "[Error] Wrong host.")))) + + (def + (fn [compiler] + (|case (get$ $host compiler) + ( host-data) + (return* compiler true) + + _ + (return* compiler false)))) + + (defn [slot updater] + (|do [host ] + (fn [compiler] + (return* (set$ $host ( (update$ slot updater host)) compiler) + (get$ slot host))))) + + (defn [slot updater body] + (|do [old-val ( slot updater) + ?output-val body + new-val ( slot (fn [_] old-val))] + (return ?output-val)))) + + $Jvm jvm-host jvm? change-jvm-host-slot with-jvm-host-slot + $Js js-host js? change-js-host-slot with-js-host-slot + ) + +(do-template [ ] + (def + (|do [host jvm-host] + (return (get$ host)))) + + loader $loader + classes $classes + get-type-env $type-env + ) + +(def get-writer + (|do [host jvm-host] + (|case (get$ $writer host) + ($Some writer) + (return writer) + + _ + (fail-with-loc "[Error] Writer hasn't been set.")))) + +(defn with-writer [writer body] + (with-jvm-host-slot $writer (fn [_] ($Some writer)) body)) + +(defn with-type-env [type-env body] + "(All [a] (-> TypeEnv (Lux a) (Lux a)))" + (with-jvm-host-slot $type-env (partial |++ type-env) body)) + +(defn push-dummy-name [real-name store-name] + (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name])))) + +(def pop-dummy-name + (change-jvm-host-slot $dummy-mappings |tail)) + +(defn de-alias-class [class-name] + (|do [host jvm-host] + (return (|case (|some #(|let [[real-name store-name] %] + (if (= real-name class-name) + ($Some store-name) + $None)) + (get$ $dummy-mappings host)) + ($Some store-name) + store-name + + _ + class-name)))) (defn with-no-catches [body] "(All [a] (-> (Lux a) (Lux a)))" @@ -800,16 +888,6 @@ (fn [state] (return* state (->> state (get$ $info) (get$ $compiler-mode))))) -(def get-writer - (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] - (|case writer* - ($Some datum) - (return* state datum) - - _ - ((fail-with-loc "[Error] Writer hasn't been set.") state))))) - (def get-top-local-env (fn [state] (try (let [top (|head (get$ $scopes state))] @@ -933,18 +1011,6 @@ _ output))))) -(defn with-writer [writer body] - (fn [state] - (let [old-writer (->> state (get$ $host) (get$ $writer)) - output (body (update$ $host #(set$ $writer ($Some writer) %) state))] - (|case output - ($Right ?state ?value) - (return* (update$ $host #(set$ $writer old-writer %) ?state) - ?value) - - _ - output)))) - (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] @@ -1333,40 +1399,6 @@ output output))) -(defn |some [f xs] - "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" - (|case xs - ($Nil) - $None - - ($Cons x xs*) - (|case (f x) - ($None) (|some f xs*) - output output) - )) - -(def get-type-env - "(Lux TypeEnv)" - (fn [state] - (return* state (->> state (get$ $host) (get$ $type-env))))) - -(defn with-type-env [type-env body] - "(All [a] (-> TypeEnv (Lux a) (Lux a)))" - (fn [state] - (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %) - state)] - (|case (body state*) - ($Right [state** output]) - ($Right (T [(update$ $host - #(set$ $type-env - (->> state (get$ $host) (get$ $type-env)) - %) - state**) - output])) - - ($Left msg) - ($Left msg))))) - (defn |take [n xs] (|case (T [n xs]) [0 _] $Nil @@ -1412,38 +1444,6 @@ ($Left msg) ($Left msg)))) -(defn push-dummy-name [real-name store-name] - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - (partial $Cons (T [real-name store-name])) - %) - state) - nil])))) - -(def pop-dummy-name - (fn [state] - ($Right (T [(update$ $host - #(update$ $dummy-mappings - |tail - %) - state) - nil])))) - -(defn de-alias-class [class-name] - (fn [state] - ($Right (T [state - (|case (|some #(|let [[real-name store-name] %] - (if (= real-name class-name) - ($Some store-name) - $None)) - (->> state (get$ $host) (get$ $dummy-mappings))) - ($Some store-name) - store-name - - _ - class-name)])))) - (defn |eitherL [left right] (fn [compiler] (|case (run-state left compiler) diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj index 77e4221e8..7299b7166 100644 --- a/luxc/src/lux/compiler/cache.clj +++ b/luxc/src/lux/compiler/cache.clj @@ -23,7 +23,7 @@ :when (not (.isDirectory f))] (.delete f))) -(defn ^:private module-path [module] +(defn ^:private ^String module-path [module] (str @&&core/!output-dir java.io.File/separator (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj index 6dacb4e54..15f03ea6e 100644 --- a/luxc/src/lux/compiler/core.clj +++ b/luxc/src/lux/compiler/core.clj @@ -4,9 +4,7 @@ [clojure.java.io :as io] [clojure.core.match :as M :refer [matchv]] clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail*]] - [type :as &type] - [host :as &host]) + (lux [base :as & :refer [|let |do return* return fail*]]) (lux.analyser [base :as &a] [module :as &a-module]) (lux.compiler.cache [type :as &&&type] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 18b91f5bc..b43ab5b4d 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -137,7 +137,7 @@ (if module-exists? (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) (|do [_ (&&cache/delete name) - _ &&/init-buffer + _ (&&/init-buffer) _ (&a-module/create-module name file-hash) _ (&a-module/flag-active-module name) _ (if (= "lux" name) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 50ece15e6..329252798 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -24,49 +24,40 @@ "buffer"]) (defn js-host [] - (&/T [;; "interpreter" - (.getScriptEngine (new NashornScriptEngineFactory)) - ;; "buffer" - &/$None - ])) + (&/$Js (&/T [;; "interpreter" + (.getScriptEngine (new NashornScriptEngineFactory)) + ;; "buffer" + &/$None + ]))) (def ^String module-js-name "module.js") -(def init-buffer - (fn [compiler-state] - (&/$Right (&/T [(&/update$ &/$host - (fn [host] - (&/set$ $buffer - (&/$Some (new StringBuilder)) - host)) - compiler-state) - nil])))) +(defn init-buffer [] + (&/change-js-host-slot $buffer (fn [_] (&/$Some (new StringBuilder))))) (def get-buffer - (fn [compiler-state] - (|case (->> compiler-state (&/get$ &/$host) (&/get$ $buffer)) + (|do [host &/js-host] + (|case (&/get$ $buffer host) (&/$Some _buffer) - (&/$Right (&/T [compiler-state - _buffer])) + (return _buffer) (&/$None) - (&/$Left "[Error] No buffer available.")))) + (&/fail-with-loc "[Error] No buffer available.")))) (defn run-js! [^String js-code] - (fn [compiler-state] - (|let [^NashornScriptEngine interpreter (->> compiler-state (&/get$ &/$host) (&/get$ $interpreter))] - (try (&/$Right (&/T [compiler-state - (.eval interpreter js-code)])) - (catch Exception ex - (&/$Left (str ex))))))) + (|do [host &/js-host + :let [interpreter ^NashornScriptEngine (&/get$ $interpreter host)]] + (try (return (.eval interpreter js-code)) + (catch Exception ex + (&/fail-with-loc (str ex)))))) (def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) -(defn ^:private _slice_ [wrap-lux-obj value] +(defn ^:private _slice_ [wrap-lux-obj ^"[Ljava.lang.Object;" value] (reify JSObject (isFunction [self] true) (call [self this args] - (let [slice (java.util.Arrays/copyOfRange value (aget args 0) (alength value))] + (let [slice (java.util.Arrays/copyOfRange value ^int (aget args 0) ^int (alength value))] (wrap-lux-obj slice))))) (defn ^:private _toString_ [obj] @@ -102,7 +93,7 @@ ;; else (assert false (str "encode-char#getMember = " member)))))) -(deftype LuxJsObject [obj] +(deftype LuxJsObject [^"[Ljava.lang.Object;" obj] JSObject (isFunction [self] false) (getSlot [self idx] @@ -139,7 +130,7 @@ (.hasMember js-object "C")) (defn ^:private decode-char [^ScriptObjectMirror js-object] - (-> (.getMember js-object "C") + (-> ^String (.getMember js-object "C") (.charAt 0))) (defn ^:private parse-int64 [^ScriptObjectMirror js-object] diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 0f86d8a33..5103b2d2b 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -314,8 +314,7 @@ ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")")))) (defn compile-def [compile ?name ?body def-meta] - (|do [module-name &/get-module-name - class-loader &/loader] + (|do [module-name &/get-module-name] (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) (&/$Some (&/$IdentA [r-module r-name])) (if (= 1 (&/|length def-meta)) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index f09224c90..5cc3c1f79 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -140,7 +140,7 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))) (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) @@ -148,7 +148,7 @@ :let [_ (.visitCode *writer*)] _ (compile-expression nil expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -158,7 +158,7 @@ _ (&&/save-class! (str id) bytecode) loader &/loader] (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) - (.getField &/eval-field) + (.getField &/value-field) (.get nil) return)))) @@ -228,19 +228,19 @@ (defn jvm-host [] (let [store (atom {})] - (&/T [;; "lux;writer" - &/$None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; "lux;module-states" - (&/|table) - ;; lux;type-env - (&/|table) - ;; lux;dummy-mappings - (&/|table) - ]))) + (&/$Jvm (&/T [;; "lux;writer" + &/$None + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store + ;; "lux;module-states" + (&/|table) + ;; lux;type-env + (&/|table) + ;; lux;dummy-mappings + (&/|table) + ])))) (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index d3805cabc..ad185e284 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -649,7 +649,7 @@ (def ^:private init-fixpoints &/$Nil) -(defn ^:private check* [class-loader fixpoints invariant?? expected actual] +(defn ^:private check* [fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) (return fixpoints) (&/with-attempt @@ -677,13 +677,13 @@ (return fixpoints)) [(&/$Some etype) (&/$None _)] - (check* class-loader fixpoints invariant?? etype actual) + (check* fixpoints invariant?? etype actual) [(&/$None _) (&/$Some atype)] - (check* class-loader fixpoints invariant?? expected atype) + (check* fixpoints invariant?? expected atype) [(&/$Some etype) (&/$Some atype)] - (check* class-loader fixpoints invariant?? etype atype)))) + (check* fixpoints invariant?? etype atype)))) [(&/$VarT ?id) _] (fn [state] @@ -693,7 +693,7 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? bound actual)) + (check* fixpoints invariant?? bound actual)) state))) [_ (&/$VarT ?id)] @@ -704,18 +704,18 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints invariant?? expected bound)) + (check* fixpoints invariant?? expected bound)) state))) [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] (if (= eid aid) - (check* class-loader fixpoints invariant?? eA aA) + (check* fixpoints invariant?? eA aA) (check-error "" expected actual)) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual)) + (check* fixpoints invariant?? (&/$AppT F1 A1) actual)) state) (&/$Right state* output) (return* state* output) @@ -724,34 +724,34 @@ (|case F2 (&/$UnivQ (&/$Cons _) _) ((|do [actual* (apply-type F2 A2)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) state) (&/$ExT _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)] - (check* class-loader fixpoints* invariant?? A1 A2)) + ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)] + (check* fixpoints* invariant?? A1 A2)) state) _ - ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2) + ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) + (check* fixpoints* invariant?? e* a*)) state)))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2))) + (check* fixpoints invariant?? expected (&/$AppT F2 A2))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id)) + ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2)] - (check* class-loader fixpoints* invariant?? e* a*)) + (check* fixpoints* invariant?? e* a*)) state))) [(&/$AppT F A) _] @@ -773,25 +773,25 @@ (&/$None) (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) + (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) [_ (&/$AppT (&/$ExT aid) A)] (check-error "" expected actual) [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] (|do [$arg existential expected* (apply-type expected $arg)] - (check* class-loader fixpoints invariant?? expected* actual)) + (check* fixpoints invariant?? expected* actual)) [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg) - =output (check* class-loader fixpoints invariant?? expected actual*) + =output (check* fixpoints invariant?? expected actual*) _ (clean $arg expected)] (return =output)))) @@ -799,24 +799,34 @@ (with-var (fn [$arg] (|do [expected* (apply-type expected $arg) - =output (check* class-loader fixpoints invariant?? expected* actual) + =output (check* fixpoints invariant?? expected* actual) _ (clean $arg actual)] (return =output)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential actual* (apply-type actual $arg)] - (check* class-loader fixpoints invariant?? expected actual*)) + (check* fixpoints invariant?? expected actual*)) [(&/$HostT e!data) (&/$HostT a!data)] - (&&host/check-host-types (partial check* class-loader fixpoints true) - check-error - fixpoints - existential - class-loader - invariant?? - e!data - a!data) + (|do [? &/jvm?] + (if ? + (|do [class-loader &/loader] + (&&host/check-host-types (partial check* fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data)) + (|let [[e!name e!params] e!data + [a!name a!params] a!data] + (if (and (= e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)] + (return fixpoints)) + (check-error "" expected actual))))) [(&/$VoidT) (&/$VoidT)] (return fixpoints) @@ -825,16 +835,16 @@ (return fixpoints) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)] - (check* class-loader fixpoints* invariant?? eO aO)) + (|do [fixpoints* (check* fixpoints invariant?? aI eI)] + (check* fixpoints* invariant?? eO aO)) [(&/$ProdT eL eR) (&/$ProdT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) [(&/$SumT eL eR) (&/$SumT aL aR)] - (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)] - (check* class-loader fixpoints* invariant?? eR aR)) + (|do [fixpoints* (check* fixpoints invariant?? eL aL)] + (check* fixpoints* invariant?? eR aR)) [(&/$ExT e!id) (&/$ExT a!id)] (if (= e!id a!id) @@ -842,10 +852,10 @@ (check-error "" expected actual)) [(&/$NamedT _ ?etype) _] - (check* class-loader fixpoints invariant?? ?etype actual) + (check* fixpoints invariant?? ?etype actual) [_ (&/$NamedT _ ?atype)] - (check* class-loader fixpoints invariant?? expected ?atype) + (check* fixpoints invariant?? expected ?atype) [_ _] (&/fail "")) @@ -853,8 +863,7 @@ (check-error err expected actual))))) (defn check [expected actual] - (|do [class-loader &/loader - _ (check* class-loader init-fixpoints false expected actual)] + (|do [_ (check* init-fixpoints false expected actual)] (return nil))) (defn actual-type [type] -- cgit v1.2.3 From 34f2995ba2bc86fbd400587b89cc21461ace37fe Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 17:51:28 -0400 Subject: - Now making sure custom analysis of per-platform procedures requires that the compiler is running for the correct host platform. --- luxc/src/lux/analyser.clj | 3 ++- luxc/src/lux/base.clj | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 280085777..5f35d3c25 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -134,7 +134,8 @@ (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type (case ?category - "jvm" (&&jvm/analyse-host analyse exo-type compilers ?proc ?args) + "jvm" (|do [_ &/jvm-host] + (&&jvm/analyse-host analyse exo-type compilers ?proc ?args)) ;; "js" ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index df4fb293f..27de43765 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -731,7 +731,7 @@ (return* compiler host-data) _ - (fail* "[Error] Wrong host.")))) + ((fail-with-loc "[Error] Wrong host.") compiler)))) (def (fn [compiler] -- cgit v1.2.3 From 69c8192026f8cb28daa1d179a0a4c3cd2f3a0e6b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 17:52:16 -0400 Subject: - The lexer can now recognize a escape-character for vertical tabs (\v). --- luxc/src/lux/lexer.clj | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'luxc/src') diff --git a/luxc/src/lux/lexer.clj b/luxc/src/lux/lexer.clj index 38fa15cd0..2f9c0717e 100644 --- a/luxc/src/lux/lexer.clj +++ b/luxc/src/lux/lexer.clj @@ -30,6 +30,7 @@ (defn ^:private escape-char [escaped] "(-> Text (Lux Text))" (cond (.equals ^Object escaped "\\t") (return "\t") + (.equals ^Object escaped "\\v") (return "\u000B") (.equals ^Object escaped "\\b") (return "\b") (.equals ^Object escaped "\\n") (return "\n") (.equals ^Object escaped "\\r") (return "\r") @@ -42,6 +43,7 @@ (defn ^:private escape-char* [escaped] "(-> Text Text)" (cond (.equals ^Object escaped "\\t") "\t" + (.equals ^Object escaped "\\v") "\u000B" (.equals ^Object escaped "\\b") "\b" (.equals ^Object escaped "\\n") "\n" (.equals ^Object escaped "\\r") "\r" @@ -63,6 +65,8 @@ (case (.charAt raw-line (+ 1 idx)) \t (do (.append buffer "\t") (recur (+ 2 idx))) + \v (do (.append buffer "\u000B") + (recur (+ 2 idx))) \b (do (.append buffer "\b") (recur (+ 2 idx))) \n (do (.append buffer "\n") -- cgit v1.2.3 From efe1e3a69663b06daeb6ba63d3d823500417b73f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 17:52:39 -0400 Subject: - Fixed a bug in the way characters where getting compiled to JS. --- luxc/src/lux/compiler/js/lux.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 5103b2d2b..4e7ddd8fd 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -46,7 +46,7 @@ (return (str value))) (defn compile-char [value] - (return (str "{C:\"" value "\"}"))) + (return (str "{C:" (pr-str (str value)) "}"))) (defn compile-text [?value] (return (pr-str ?value))) -- cgit v1.2.3 From 03a41265b2619257be45fddac691cb5bc18765a7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 17:53:11 -0400 Subject: - No longer (uselessly) loading classes right after they get saved. --- luxc/src/lux/compiler/jvm/base.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/jvm/base.clj b/luxc/src/lux/compiler/jvm/base.clj index 268b293e9..99e0f08e9 100644 --- a/luxc/src/lux/compiler/jvm/base.clj +++ b/luxc/src/lux/compiler/jvm/base.clj @@ -52,7 +52,6 @@ ;; [Exports] (defn ^Class load-class! [^ClassLoader loader name] - ;; (prn 'load-class! name) (.loadClass loader name)) (defn save-class! [name bytecode] @@ -64,7 +63,8 @@ _ (swap! !classes assoc real-name bytecode) _ (when (not eval?) (write-output module name bytecode)) - _ (load-class! loader real-name)]] + ;; _ (load-class! loader real-name) + ]] (return nil))) (do-template [ ] -- cgit v1.2.3 From 38a81332a1cefb51ff89ee96a16bb4a65cee21bc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 18:01:05 -0400 Subject: - Implemented a variety of new procedures for text, chars, math and arrays. --- luxc/src/lux/analyser/proc/common.clj | 140 +++++++++++++++++--- luxc/src/lux/compiler/js/proc/common.clj | 150 ++++++++++++++++------ luxc/src/lux/compiler/js/rt.clj | 36 +++++- luxc/src/lux/compiler/jvm/proc/common.clj | 206 +++++++++++++++++++++++++++--- 4 files changed, 458 insertions(+), 74 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index bec0855e1..9ab01801f 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -28,25 +28,38 @@ (&&/$proc (&/T ) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bool ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) -(do-template [ ] +(do-template [ ] (defn [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Cons start (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) =part (&&/analyse-1 analyse &type/Text part) - _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + =start (&&/analyse-1 analyse &type/Nat start) + _ (&type/check exo-type ) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" ]) - (&/|list =text =part) + (&/|list =text =part =start) (&/|list))))))) - ^:private analyse-text-index "index" - ^:private analyse-text-last-index "last-index" + ^:private analyse-text-index "index" (&/$AppT &type/Maybe &type/Nat) + ^:private analyse-text-last-index "last-index" (&/$AppT &type/Maybe &type/Nat) ) +(defn ^:private analyse-text-contains? [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "contains?"]) + (&/|list =text =part) + (&/|list))))))) + (defn ^:private analyse-text-clip [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) @@ -71,15 +84,20 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) - (&/|list))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" ]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-size "size" + ^:private analyse-text-hash "hash" + ) (do-template [ ] (defn [analyse exo-type ?values] @@ -187,6 +205,9 @@ ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool + + ^:private analyse-char-eq ["char" "="] &type/Char &type/Bool + ^:private analyse-char-lt ["char" "<"] &type/Char &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -328,6 +349,61 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list) (&/|list))))))) + + ^:private analyse-math-e "e" + ^:private analyse-math-pi "pi" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input) (&/|list))))))) + + ^:private analyse-math-cos "cos" + ^:private analyse-math-sin "sin" + ^:private analyse-math-tan "tan" + ^:private analyse-math-acos "acos" + ^:private analyse-math-asin "asin" + ^:private analyse-math-atan "atan" + ^:private analyse-math-cosh "cosh" + ^:private analyse-math-sinh "sinh" + ^:private analyse-math-tanh "tanh" + ^:private analyse-math-exp "exp" + ^:private analyse-math-log "log" + ^:private analyse-math-root2 "root2" + ^:private analyse-math-root3 "root3" + ^:private analyse-math-degrees "degrees" + ^:private analyse-math-radians "radians" + ^:private analyse-math-ceil "ceil" + ^:private analyse-math-floor "floor" + ^:private analyse-math-round "round" + ) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + =param (&&/analyse-1 analyse &type/Real ?param) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" ]) (&/|list =input =param) (&/|list))))))) + + ^:private analyse-math-atan2 "atan2" + ^:private analyse-math-pow "pow" + ) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -342,16 +418,20 @@ "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) + "<" (analyse-text-lt analyse exo-type ?values) "append" (analyse-text-append analyse exo-type ?values) "clip" (analyse-text-clip analyse exo-type ?values) "index" (analyse-text-index analyse exo-type ?values) "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) + "hash" (analyse-text-hash analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) "trim" (analyse-text-trim analyse exo-type ?values) "char" (analyse-text-char analyse exo-type ?values) "upper-case" (analyse-text-upper-case analyse exo-type ?values) - "lower-case" (analyse-text-lower-case analyse exo-type ?values)) + "lower-case" (analyse-text-lower-case analyse exo-type ?values) + "contains?" (analyse-text-contains? analyse exo-type ?values) + ) "bit" (case proc @@ -445,9 +525,37 @@ "char" (case proc + "=" (analyse-char-eq analyse exo-type ?values) + "<" (analyse-char-lt analyse exo-type ?values) "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) + + "math" + (case proc + "e" (analyse-math-e analyse exo-type ?values) + "pi" (analyse-math-pi analyse exo-type ?values) + "cos" (analyse-math-cos analyse exo-type ?values) + "sin" (analyse-math-sin analyse exo-type ?values) + "tan" (analyse-math-tan analyse exo-type ?values) + "acos" (analyse-math-acos analyse exo-type ?values) + "asin" (analyse-math-asin analyse exo-type ?values) + "atan" (analyse-math-atan analyse exo-type ?values) + "cosh" (analyse-math-cosh analyse exo-type ?values) + "sinh" (analyse-math-sinh analyse exo-type ?values) + "tanh" (analyse-math-tanh analyse exo-type ?values) + "exp" (analyse-math-exp analyse exo-type ?values) + "log" (analyse-math-log analyse exo-type ?values) + "root2" (analyse-math-root2 analyse exo-type ?values) + "root3" (analyse-math-root3 analyse exo-type ?values) + "degrees" (analyse-math-degrees analyse exo-type ?values) + "radians" (analyse-math-radians analyse exo-type ?values) + "ceil" (analyse-math-ceil analyse exo-type ?values) + "floor" (analyse-math-floor analyse exo-type ?values) + "round" (analyse-math-round analyse exo-type ?values) + "atan2" (analyse-math-atan2 analyse exo-type ?values) + "pow" (analyse-math-pow analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index ee381add4..11fb9fd95 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -69,6 +69,43 @@ =right (compile ?right)] (return (str "(" =left " === " =right ")")))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + =length (compile ?length)] + (return (str "new Array(" (str "LuxRT.toNumberI64(" =length ")") ")")))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayGet(" =array "," =idx ")")))) + +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx) + =elem (compile ?elem)] + (return (str "LuxRT.arrayPut(" =array "," =idx "," =elem ")")))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayRemove(" =array "," =idx ")")))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array)] + (return (str =array ".length")))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -134,10 +171,14 @@ ^:private compile-deg-decode "decodeD64" ^:private compile-real-decode "decodeReal" - - ^:private compile-real-hash "hashReal" ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT ".textHash(''+" =x ")")) + )) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] @@ -222,28 +263,6 @@ ;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long ;; ) -;; (let [widen (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/I2L))) -;; shrink (fn [^MethodVisitor *writer*] -;; (doto *writer* -;; (.visitInsn Opcodes/L2I) -;; (.visitInsn Opcodes/I2C)))] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; -;; )]] -;; (return nil))) - -;; ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink -;; ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen -;; )) - (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] @@ -273,11 +292,27 @@ =x (compile ?x)] (return (str "LuxRT.realToDeg(" =x ")")))) -(defn ^:private compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x "===" =y ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x =y ")")))) + + ^:private compile-text-eq "===" + ^:private compile-text-lt "<" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x ".C" " " " " =y ".C" ")")))) + + ^:private compile-char-eq "===" + ^:private compile-char-lt "<" + ) (defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -287,15 +322,26 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] =text (compile ?text) - =part (compile ?part)] - (return (str "LuxRT" "." "(" =text "," =part ")")))) + =part (compile ?part) + =start (compile ?start)] + (return (str "LuxRT" "." "(" =text "," =part "," =start ")")))) ^:private compile-text-last-index "lastIndex" ^:private compile-text-index "index" ) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "(" (str (str "(" =text ")") + ".indexOf" + (str "(" =part ")")) + " !== " "-1" + ")")))) + (defn ^:private compile-text-clip [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] =text (compile ?text) @@ -315,6 +361,11 @@ =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.textHash(" =text ")")))) + (defn ^:private compile-text-char [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] =text (compile ?text) @@ -337,6 +388,20 @@ =x (compile ?x)] (return (str "(" =x ").C")))) +(defn ^:private compile-char-to-nat [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) + +(defn ^:private compile-nat-to-char [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "{C:" + (str "String.fromCharCode(" + (str "LuxRT.toNumberI64(" =x ")") + ")") + "}")))) + (defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] @@ -361,16 +426,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) ;; "bit" @@ -383,9 +451,13 @@ ;; "shift-right" (compile-bit-shift-right compile ?values special-args) ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) - ;; "array" - ;; (case proc-name - ;; "get" (compile-array-get compile ?values special-args)) + "array" + (case proc-name + "new" (compile-array-new compile ?values special-args) + "get" (compile-array-get compile ?values special-args) + "put" (compile-array-put compile ?values special-args) + "remove" (compile-array-remove compile ?values special-args) + "size" (compile-array-size compile ?values special-args)) "nat" (case proc-name @@ -401,7 +473,7 @@ "max-value" (compile-nat-max-value compile ?values special-args) "min-value" (compile-nat-min-value compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) - ;; "to-char" (compile-nat-to-char compile ?values special-args) + "to-char" (compile-nat-to-char compile ?values special-args) ) "int" @@ -461,8 +533,10 @@ "char" (case proc-name - "to-text" (compile-char-to-text compile ?values special-args) - ;; "to-nat" (compile-char-to-nat compile ?values special-args) + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) + "to-nat" (compile-char-to-nat compile ?values special-args) ) ;; else diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index eaac37a6a..cc00e2908 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1233,8 +1233,8 @@ (str "[1,''," value "]")) (def ^:private text-methods - {"index" (str "(function index(text,part) {" - "var idx = text.indexOf(part);" + {"index" (str "(function index(text,part,start) {" + "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1242,8 +1242,8 @@ (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") "}")) "})") - "lastIndex" (str "(function lastIndex(text,part) {" - "var idx = text.lastIndexOf(part);" + "lastIndex" (str "(function lastIndex(text,part,start) {" + "var idx = text.lastIndexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1275,6 +1275,33 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textHash" (str "(function(input) {" + "var hash = 0;" + (str "for(var i = 0; i < input.length; i++) {" + "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" + "}") + "return LuxRT.fromNumberI64(hash);" + "})") + }) + +(def ^:private array-methods + {"arrayGet" (str "(function arrayGet(arr,idx) {" + "var temp = arr[LuxRT.toNumberI64(idx)];" + (str "if(temp !== undefined) {" + (str "return " (make-some "temp") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") + "arrayPut" (str "(function arrayPut(arr,idx,val) {" + "arr[LuxRT.toNumberI64(idx)] = val;" + "return arr;" + "})") + "arrayRemove" (str "(function arrayRemove(arr,idx) {" + "delete arr[LuxRT.toNumberI64(idx)];" + "return arr;" + "})") }) (def LuxRT "LuxRT") @@ -1285,6 +1312,7 @@ i64-methods n64-methods text-methods + array-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 01048fd98..63e7b9e76 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,31 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + )] + _ (compile ?y) + :let [_ (doto *writer* + ) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + + ^:private compile-char-eq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char + ) + (defn ^:private compile-real-hash [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer @@ -496,7 +521,7 @@ ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double ) -(defn compile-text-eq [compile ?values special-args] +(defn ^:private compile-text-eq [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -506,6 +531,28 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-text-lt [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") + (.visitLdcInsn (int -1)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) + (.visitLabel $end))]] + (return nil))) + (defn compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -539,7 +586,7 @@ (do-template [ ] (defn [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* @@ -547,8 +594,12 @@ _ (compile ?part) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;)I"))] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "(Ljava/lang/String;I)I"))] :let [$not-found (new Label) $end (new Label) _ (doto *writer* @@ -569,16 +620,21 @@ ^:private compile-text-last-index "lastIndexOf" ) -(defn ^:private compile-text-size [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + + ^:private compile-text-size "java/lang/String" "length" + ^:private compile-text-hash "java/lang/Object" "hashCode" + ) (defn ^:private compile-text-replace-all [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] @@ -596,6 +652,20 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?sub (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?sub) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "contains" "(Ljava/lang/CharSequence;)Z") + &&/wrap-boolean)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] @@ -624,7 +694,7 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) -(defn compile-io-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -636,7 +706,7 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) -(defn compile-io-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -649,6 +719,79 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" "D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(D)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-degrees "toDegrees" + ^:private compile-math-radians "toRadians" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double)] + _ (compile ?param) + :let [_ (doto *writer* + &&/unwrap-double)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "(DD)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + +(defn ^:private compile-math-round [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "round" "(D)J") + (.visitInsn Opcodes/L2D) + &&/wrap-double)]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" @@ -663,16 +806,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) - "char" (compile-text-char compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) "bit" @@ -767,9 +913,37 @@ "char" (case proc-name + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) "to-text" (compile-char-to-text compile ?values special-args) ) + + "math" + (case proc-name + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "degrees" (compile-math-degrees compile ?values special-args) + "radians" (compile-math-radians compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) -- cgit v1.2.3 From 879455eafe4e3a6eed69219d5ebfa61d421af99c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Feb 2017 20:08:17 -0400 Subject: - Fixed a bug in the way the low and high 32 bits in a long were extracted and cast to ints. --- luxc/src/lux/compiler/js/base.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 329252798..c6a6f538c 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -79,8 +79,8 @@ JSObject (getMember [self member] (condp = member - "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) - "L" (-> value (bit-and i64-mask) int) + "H" (-> value (bit-shift-right 32) int) + "L" (-> value (bit-and i64-mask) (bit-shift-left 32) (bit-shift-right 32) int) ;; else (assert false (str "I64#getMember = " member))))) -- cgit v1.2.3 From 5fb0985b7a33ccfc6c53d65ce00a643f9d8d20ee Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 18:12:42 -0400 Subject: - Re-designed atomic operations as common procedures. - Implemented atomic operations for the JVM. - Basic Lux types no longer rely on JVM classes. --- luxc/src/lux/analyser/proc/common.clj | 39 +++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 69 +++++++++++++++++++++++------ luxc/src/lux/type.clj | 25 ++++++----- luxc/src/lux/type/host.clj | 72 +++++++++++++++---------------- 4 files changed, 144 insertions(+), 61 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 9ab01801f..51e0f3528 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -404,6 +404,38 @@ ^:private analyse-math-pow "pow" ) +(defn ^:private analyse-atom-new [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + =init (&&/analyse-1 analyse $var ?init) + _ (&type/check exo-type (&type/Atom $var)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "new"]) (&/|list =init) (&/|list))))))))) + +(defn ^:private analyse-atom-get [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] + =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom) + _ (&type/check exo-type $var) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "get"]) (&/|list =atom) (&/|list))))))))) + +(defn ^:private analyse-atom-compare-and-swap [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] + =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom) + =old (&&/analyse-1 analyse $var ?old) + =new (&&/analyse-1 analyse $var ?new) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list))))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -556,6 +588,13 @@ "atan2" (analyse-math-atan2 analyse exo-type ?values) "pow" (analyse-math-pow analyse exo-type ?values) ) + + "atom" + (case proc + "new" (analyse-atom-new analyse exo-type ?values) + "get" (analyse-atom-get analyse exo-type ?values) + "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 63e7b9e76..dd59a41f0 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -792,19 +792,53 @@ &&/wrap-double)]] (return nil))) -(defn compile-proc [compile proc-category proc-name ?values special-args] - (case proc-category +(defn ^:private compile-atom-new [compile ?values special-args] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/util/concurrent/atomic/AtomicReference") + (.visitInsn Opcodes/DUP))] + _ (compile ?init) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/atomic/AtomicReference" "" "(Ljava/lang/Object;)V"))]] + (return nil))) + +(defn ^:private compile-atom-get [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?atom) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "get" "()Ljava/lang/Object;"))]] + (return nil))) + +(defn ^:private compile-atom-compare-and-swap [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?atom) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))] + _ (compile ?old) + _ (compile ?new) + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "compareAndSet" "(Ljava/lang/Object;Ljava/lang/Object;)Z") + &&/wrap-boolean)]] + (return nil))) + +(defn compile-proc [compile category proc ?values special-args] + (case category "lux" - (case proc-name + (case proc "is" (compile-lux-is compile ?values special-args)) "io" - (case proc-name + (case proc "log" (compile-io-log compile ?values special-args) "error" (compile-io-error compile ?values special-args)) "text" - (case proc-name + (case proc "=" (compile-text-eq compile ?values special-args) "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) @@ -822,7 +856,7 @@ ) "bit" - (case proc-name + (case proc "count" (compile-bit-count compile ?values special-args) "and" (compile-bit-and compile ?values special-args) "or" (compile-bit-or compile ?values special-args) @@ -832,7 +866,7 @@ "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) "array" - (case proc-name + (case proc "new" (compile-array-new compile ?values special-args) "get" (compile-array-get compile ?values special-args) "put" (compile-array-put compile ?values special-args) @@ -840,7 +874,7 @@ "size" (compile-array-size compile ?values special-args)) "nat" - (case proc-name + (case proc "+" (compile-nat-add compile ?values special-args) "-" (compile-nat-sub compile ?values special-args) "*" (compile-nat-mul compile ?values special-args) @@ -857,7 +891,7 @@ ) "deg" - (case proc-name + (case proc "+" (compile-deg-add compile ?values special-args) "-" (compile-deg-sub compile ?values special-args) "*" (compile-deg-mul compile ?values special-args) @@ -874,7 +908,7 @@ ) "int" - (case proc-name + (case proc "+" (compile-int-add compile ?values special-args) "-" (compile-int-sub compile ?values special-args) "*" (compile-int-mul compile ?values special-args) @@ -891,7 +925,7 @@ ) "real" - (case proc-name + (case proc "+" (compile-real-add compile ?values special-args) "-" (compile-real-sub compile ?values special-args) "*" (compile-real-mul compile ?values special-args) @@ -912,7 +946,7 @@ ) "char" - (case proc-name + (case proc "=" (compile-char-eq compile ?values special-args) "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) @@ -920,7 +954,7 @@ ) "math" - (case proc-name + (case proc "e" (compile-math-e compile ?values special-args) "pi" (compile-math-pi compile ?values special-args) "cos" (compile-math-cos compile ?values special-args) @@ -944,6 +978,13 @@ "atan2" (compile-math-atan2 compile ?values special-args) "pow" (compile-math-pow compile ?values special-args) ) + + "atom" + (case proc + "new" (compile-atom-new compile ?values special-args) + "get" (compile-atom-get compile ?values special-args) + "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) + ) ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) + (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index ad185e284..94c4e2ae7 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -23,17 +23,22 @@ (def empty-env &/$Nil) -(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) +(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "#Bool" &/$Nil))) (def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) (def Deg (&/$NamedT (&/T ["lux" "Deg"]) (&/$HostT &&host/deg-data-tag &/$Nil))) -(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) -(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) -(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) -(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil))) +(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "#Int" &/$Nil))) +(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "#Real" &/$Nil))) +(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "#Char" &/$Nil))) +(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "#Text" &/$Nil))) (def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text))) -(defn Array [elem-type] - (&/$HostT "#Array" (&/|list elem-type))) +(do-template [ ] + (defn [elem-type] + (&/$HostT (&/|list elem-type))) + + Array "#Array" + Atom "#Atom" + ) (def Bottom (&/$NamedT (&/T ["lux" "Bottom"]) @@ -205,7 +210,7 @@ (&/$None) (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil)) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -215,7 +220,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -225,7 +230,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj index b255f97c5..40a3373f0 100644 --- a/luxc/src/lux/type/host.clj +++ b/luxc/src/lux/type/host.clj @@ -250,45 +250,43 @@ (defn primitive-type? [type-name] (contains? primitive-types type-name))) +(def ^:private lux-jvm-type-combos + #{#{"java.lang.Boolean" "#Bool"} + #{"java.lang.Long" "#Int"} + #{"java.lang.Double" "#Real"} + #{"java.lang.Character" "#Char"} + #{"java.lang.String" "#Text"}}) + +(defn ^:private lux-type? [^String class-name] + (.startsWith class-name "#")) + (defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual] - (|let [[e!name e!params] expected - [a!name a!params] actual] - ;; TODO: Delete first branch. It smells like a hack... - (try (cond (or (= "java.lang.Object" e!name) - (and (= nat-data-tag e!name) - (= nat-data-tag a!name)) - (and (= deg-data-tag e!name) - (= deg-data-tag a!name)) - (and (= null-data-tag e!name) - (= null-data-tag a!name)) - (and (not (primitive-type? e!name)) - (= null-data-tag a!name))) - (return fixpoints) - - (or (and (= array-data-tag e!name) - (not= array-data-tag a!name)) - (= nat-data-tag e!name) (= nat-data-tag a!name) - (= deg-data-tag e!name) (= deg-data-tag a!name) - (= null-data-tag e!name) (= null-data-tag a!name)) - (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) - - :else - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (cond (= e!name a!name) - (if (= (&/|length e!params) (&/|length a!params)) - (|do [_ (&/map2% check e!params a!params)] - (return fixpoints)) - (&/fail-with-loc (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")"))) - - (not invariant??) - (|do [actual* (->super-type existential class-loader e!name a!name a!params)] - (check (&/$HostT e!name e!params) actual*)) - - :else - (&/fail-with-loc (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + (|let [[^String e!name e!params] expected + [^String a!name a!params] actual] + (try (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (= e!name a!name) + (if (= (&/|length e!params) (&/|length a!params)) + (|do [_ (&/map2% check e!params a!params)] + (return fixpoints)) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))) + + (or (lux-type? e!name) + (lux-type? a!name)) + (if (or (= "java.lang.Object" e!name) + (contains? lux-jvm-type-combos #{e!name a!name}) + (and (not (primitive-type? e!name)) + (= null-data-tag a!name))) + (return fixpoints) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))) + + (not invariant??) + (|do [actual* (->super-type existential class-loader e!name a!name a!params)] + (check (&/$HostT e!name e!params) actual*)) + + :else + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))) (catch Exception e - (prn 'check-host-types e [e!name a!name]) (throw e))))) (defn gtype->gclass [gtype] -- cgit v1.2.3 From 8ff8934813562f28f79cc08014947eb282256e6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 23 Feb 2017 19:46:22 -0400 Subject: - Re-designed (and implemented) the primitives for running processes/threads as Lux procedures. --- luxc/src/lux/analyser/proc/common.clj | 31 +++++++++ luxc/src/lux/compiler/jvm.clj | 3 +- luxc/src/lux/compiler/jvm/proc/common.clj | 39 +++++++++++ luxc/src/lux/compiler/jvm/rt.clj | 106 +++++++++++++++++++++++++++++- luxc/src/lux/type.clj | 5 ++ 5 files changed, 182 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 51e0f3528..7703aa8a6 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -436,6 +436,30 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list))))))))) +(defn ^:private analyse-process-concurrency-level [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "concurrency-level"]) (&/|list) (&/|list))))))) + +(defn ^:private analyse-process-future [analyse exo-type ?values] + (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] + =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure) + _ (&type/check exo-type &/$UnitT) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "future"]) (&/|list =procedure) (&/|list))))))) + +(defn ^:private analyse-process-schedule [analyse exo-type ?values] + (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] + =milliseconds (&&/analyse-1 analyse &type/Nat ?milliseconds) + =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure) + _ (&type/check exo-type &/$UnitT) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["process" "schedule"]) (&/|list =milliseconds =procedure) (&/|list))))))) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -595,6 +619,13 @@ "get" (analyse-atom-get analyse exo-type ?values) "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values) ) + + "process" + (case proc + "concurrency-level" (analyse-process-concurrency-level analyse exo-type ?values) + "future" (analyse-process-future analyse exo-type ?values) + "schedule" (analyse-process-schedule analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 5cc3c1f79..7fd764e56 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -192,7 +192,8 @@ (.visitSource file-name nil))] _ (if (= "lux" name) (|do [_ &&rt/compile-Function-class - _ &&rt/compile-LuxRT-class] + _ &&rt/compile-LuxRT-class + _ &&rt/compile-LuxRunnable-class] (return nil)) (return nil))] (fn [state] diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index dd59a41f0..0afcdc9e0 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -826,6 +826,38 @@ &&/wrap-boolean)]] (return nil))) +(defn ^:private compile-process-concurrency-level [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + +(defn ^:private compile-process-future [compile ?values special-args] + (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?procedure) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "future" "(Llux/Function;)Ljava/lang/Object;"))]] + (return nil))) + +(defn ^:private compile-process-schedule [compile ?values special-args] + (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?milliseconds) + :let [_ (doto *writer* + &&/unwrap-long)] + _ (compile ?procedure) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "schedule" "(JLlux/Function;)Ljava/lang/Object;"))]] + (return nil))) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -985,6 +1017,13 @@ "get" (compile-atom-get compile ?values special-args) "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) ) + + "process" + (case proc + "concurrency-level" (compile-process-concurrency-level compile ?values special-args) + "future" (compile-process-future compile ?values special-args) + "schedule" (compile-process-schedule compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 7f193a1cd..0f86325f2 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -25,6 +25,7 @@ (def init-method "") ;; [Resources] +;; Functions (def compile-Function-class (|do [_ (return nil) :let [super-class "java/lang/Object" @@ -65,6 +66,37 @@ (&&/save-class! (second (string/split &&/function-class #"/")) (.toByteArray (doto =class .visitEnd))))) +;; Custom Runnable +(def compile-LuxRunnable-class + (|do [_ (return nil) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + "lux/LuxRunnable" nil "java/lang/Object" (into-array String ["java/lang/Runnable"]))) + _ (doto (.visitField =class Opcodes/ACC_PUBLIC "procedure" "Llux/Function;" nil nil) + (.visitEnd)) + _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(Llux/Function;)V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" init-method "()V") + (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD 1) + (.visitFieldInsn Opcodes/PUTFIELD "lux/LuxRunnable" "procedure" "Llux/Function;") + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "run" "()V" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitFieldInsn Opcodes/GETFIELD "lux/LuxRunnable" "procedure" "Llux/Function;") + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (&&/save-class! "LuxRunnable" + (.toByteArray (doto =class .visitEnd))))) + +;; Runtime infrastructure (defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class] (|let [_ (let [$begin (new Label) $not-rec (new Label)] @@ -1281,6 +1313,77 @@ (.visitEnd))) nil)) +(defn ^:private compile-LuxRT-process-methods [^ClassWriter =class] + (do (doto (.visitField =class + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + "concurrency_level" "I" nil nil) + (.visitEnd)) + (doto (.visitField =class + (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) + "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;" nil nil) + (.visitEnd)) + (doto (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) + (.visitCode) + ;; concurrency_level + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Runtime" "getRuntime" "()Ljava/lang/Runtime;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Runtime" "availableProcessors" "()I") + (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "concurrency_level" "I") + ;; executor + (.visitTypeInsn Opcodes/NEW "java/util/concurrent/ScheduledThreadPoolExecutor") + (.visitInsn Opcodes/DUP) + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/ScheduledThreadPoolExecutor" "" "(I)V") + (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + ;; DONE + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "future" "(Llux/Function;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTypeInsn Opcodes/NEW "java/lang/Thread") + (.visitInsn Opcodes/DUP) + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Thread" "" "(Ljava/lang/Runnable;)V") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Thread" "start" "()V") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) + (let [$immediately (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "schedule" "(JLlux/Function;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFEQ $immediately) + ;; Schedule for later + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitVarInsn Opcodes/LLOAD 0) + (.visitFieldInsn Opcodes/GETSTATIC "java/util/concurrent/TimeUnit" "MILLISECONDS" "Ljava/util/concurrent/TimeUnit;") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/ScheduledThreadPoolExecutor" "schedule" "(Ljava/lang/Runnable;JLjava/util/concurrent/TimeUnit;)Ljava/util/concurrent/ScheduledFuture;") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + ;; Run immediately + (.visitLabel $immediately) + (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;") + (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable") + (.visitInsn Opcodes/DUP) + (.visitVarInsn Opcodes/ALOAD 2) + (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "" "(Llux/Function;)V") + (.visitMethodInsn Opcodes/INVOKEINTERFACE "java/util/concurrent/Executor" "execute" "(Ljava/lang/Runnable;)V") + (.visitLdcInsn &/unit-tag) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + nil)) + (def compile-LuxRT-class (|do [_ (return nil) :let [full-name &&/lux-utils-class @@ -1344,6 +1447,7 @@ (compile-LuxRT-int-methods) (compile-LuxRT-deg-methods) (compile-LuxRT-real-methods) - (compile-LuxRT-text-methods))]] + (compile-LuxRT-text-methods) + (compile-LuxRT-process-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index 94c4e2ae7..854472c94 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -45,6 +45,11 @@ (&/$UnivQ empty-env (&/$BoundT 1)))) +(def Top + (&/$NamedT (&/T ["lux" "Top"]) + (&/$ExQ empty-env + (&/$BoundT 1)))) + (def IO (&/$NamedT (&/T ["lux/codata" "IO"]) (&/$UnivQ empty-env -- cgit v1.2.3 From cbeafbafc0ab02d8c8335ccc106a90545d562985 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 25 Feb 2017 19:57:30 -0400 Subject: - Exiting the program and getting the current time (in milliseconds) is now done through procedures. --- luxc/src/lux/analyser/proc/common.clj | 19 +++++++++++++++---- luxc/src/lux/compiler/js/proc/common.clj | 8 ++++---- luxc/src/lux/compiler/jvm/proc/common.clj | 23 ++++++++++++++++++++++- 3 files changed, 41 insertions(+), 9 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 7703aa8a6..c91074676 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -291,10 +291,18 @@ ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"] ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"] - ^:private analyse-lux-log &type/Text &/$UnitT ["io" "log"] - ^:private analyse-lux-error &type/Text &type/Bottom ["io" "error"] + ^:private analyse-io-log &type/Text &/$UnitT ["io" "log"] + ^:private analyse-io-error &type/Text &type/Bottom ["io" "error"] + ^:private analyse-io-exit &type/Int &type/Bottom ["io" "exit"] ) +(defn ^:private analyse-io-current-time [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list))))))) + (defn ^:private analyse-array-new [analyse exo-type ?values] (|do [:let [(&/$Cons length (&/$Nil)) ?values] =length (&&/analyse-1 analyse &type/Nat length) @@ -468,8 +476,11 @@ "io" (case proc - "log" (analyse-lux-log analyse exo-type ?values) - "error" (analyse-lux-error analyse exo-type ?values)) + "log" (analyse-io-log analyse exo-type ?values) + "error" (analyse-io-error analyse exo-type ?values) + "exit" (analyse-io-exit analyse exo-type ?values) + "current-time" (analyse-io-current-time analyse exo-type ?values) + ) "text" (case proc diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 11fb9fd95..284139248 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -402,12 +402,12 @@ ")") "}")))) -(defn ^:private compile-lux-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.log(" =message ")")))) -(defn ^:private compile-lux-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] (return (str "LuxRT.error(" =message ")")))) @@ -420,8 +420,8 @@ "io" (case proc-name - "log" (compile-lux-log compile ?values special-args) - "error" (compile-lux-error compile ?values special-args)) + "log" (compile-io-log compile ?values special-args) + "error" (compile-io-error compile ?values special-args)) "text" (case proc-name diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 0afcdc9e0..6a952e6d3 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -719,6 +719,24 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(defn ^:private compile-io-exit [compile ?values special-args] + (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?code) + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V"))]] + (return nil))) + +(defn ^:private compile-io-current-time [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J") + &&/wrap-long)]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Nil) ?values] @@ -867,7 +885,10 @@ "io" (case proc "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args)) + "error" (compile-io-error compile ?values special-args) + "exit" (compile-io-exit compile ?values special-args) + "current-time" (compile-io-current-time compile ?values special-args) + ) "text" (case proc -- cgit v1.2.3 From c8dc7ef9af9873fa64e8a97ef0d78a0725399bab Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 13:36:53 -0400 Subject: - Implemented "atom" and "process" procedures for JS. --- luxc/src/lux/compiler/js/proc/common.clj | 87 +++++++++++++++++++++++++++----- 1 file changed, 74 insertions(+), 13 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 284139248..1522cf4ca 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -412,19 +412,66 @@ =message (compile ?message)] (return (str "LuxRT.error(" =message ")")))) -(defn compile-proc [compile proc-category proc-name ?values special-args] - (case proc-category +(defn ^:private compile-atom-new [compile ?values special-args] + (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] + =init (compile ?init)] + (return (str "{V: " =init "}")))) + +(defn ^:private compile-atom-get [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] + =atom (compile ?atom)] + (return (str =atom ".V")))) + +(defn ^:private compile-atom-compare-and-swap [compile ?values special-args] + (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] + =atom (compile ?atom) + =old (compile ?old) + =new (compile ?new)] + (return (str "(function() {" + (str "var atom = " =atom ";") + (str "if(" (str "(atom.V === " =old ")") ") {" + (str "atom.V = " =new ";") + "return true;" + "}" + "else {" + "return false;" + "}") + "})()")))) + +(defn ^:private compile-process-concurrency-level [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return (str "LuxRT.fromNumberI64(1)")))) + +(defn ^:private compile-process-future [compile ?values special-args] + (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] + =procedure (compile ?procedure)] + (return (str "setTimeout(" + (str "function() {" =procedure "(null)" "}") + ",0)")))) + +(defn ^:private compile-process-schedule [compile ?values special-args] + (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] + =milliseconds (compile ?milliseconds) + =procedure (compile ?procedure)] + (return (str "setTimeout(" + (str "function() {" =procedure "(null)" "}") + "," + (str "LuxRT.toNumberI64(" =milliseconds ")") + ")")))) + +(defn compile-proc [compile category proc ?values special-args] + (case category "lux" - (case proc-name + (case proc "is" (compile-lux-is compile ?values special-args)) "io" - (case proc-name + (case proc "log" (compile-io-log compile ?values special-args) "error" (compile-io-error compile ?values special-args)) "text" - (case proc-name + (case proc "=" (compile-text-eq compile ?values special-args) "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) @@ -442,7 +489,7 @@ ) ;; "bit" - ;; (case proc-name + ;; (case proc ;; "count" (compile-bit-count compile ?values special-args) ;; "and" (compile-bit-and compile ?values special-args) ;; "or" (compile-bit-or compile ?values special-args) @@ -452,7 +499,7 @@ ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) "array" - (case proc-name + (case proc "new" (compile-array-new compile ?values special-args) "get" (compile-array-get compile ?values special-args) "put" (compile-array-put compile ?values special-args) @@ -460,7 +507,7 @@ "size" (compile-array-size compile ?values special-args)) "nat" - (case proc-name + (case proc "+" (compile-nat-add compile ?values special-args) "-" (compile-nat-sub compile ?values special-args) "*" (compile-nat-mul compile ?values special-args) @@ -477,7 +524,7 @@ ) "int" - (case proc-name + (case proc "+" (compile-int-add compile ?values special-args) "-" (compile-int-sub compile ?values special-args) "*" (compile-int-mul compile ?values special-args) @@ -494,7 +541,7 @@ ) "deg" - (case proc-name + (case proc "+" (compile-deg-add compile ?values special-args) "-" (compile-deg-sub compile ?values special-args) "*" (compile-deg-mul compile ?values special-args) @@ -511,7 +558,7 @@ ) "real" - (case proc-name + (case proc "+" (compile-real-add compile ?values special-args) "-" (compile-real-sub compile ?values special-args) "*" (compile-real-mul compile ?values special-args) @@ -532,12 +579,26 @@ ) "char" - (case proc-name + (case proc "=" (compile-char-eq compile ?values special-args) "<" (compile-char-lt compile ?values special-args) "to-text" (compile-char-to-text compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) ) + + "atom" + (case proc + "new" (compile-atom-new compile ?values special-args) + "get" (compile-atom-get compile ?values special-args) + "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) + ) + + "process" + (case proc + "concurrency-level" (compile-process-concurrency-level compile ?values special-args) + "future" (compile-process-future compile ?values special-args) + "schedule" (compile-process-schedule compile ?values special-args) + ) ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))) + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [category proc])))) -- cgit v1.2.3 From 00cf2f245faf3ef3148bd58aa3503339be17f80d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 14:27:10 -0400 Subject: - Implemented bitwise operations in JS. --- luxc/src/lux/compiler/js/proc/common.clj | 90 +++++++++++++------------------- luxc/src/lux/compiler/js/rt.clj | 72 +++++++++++++++++++++++++ 2 files changed, 107 insertions(+), 55 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 1522cf4ca..60ade9300 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -14,54 +14,34 @@ [lux :as &&lux]))) ;; [Resources] -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?mask) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-bit-and Opcodes/LAND -;; ^:private compile-bit-or Opcodes/LOR -;; ^:private compile-bit-xor Opcodes/LXOR -;; ) - -;; (defn ^:private compile-bit-count [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I") -;; (.visitInsn Opcodes/I2L) -;; &&/wrap-long)]] -;; (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (compile ?input) + =param (compile ?param)] + (return (str "LuxRT." "(" =input "," =param ")")))) + + ^:private compile-bit-and "andI64" + ^:private compile-bit-or "orI64" + ^:private compile-bit-xor "xorI64" + ) -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?input) -;; :let [_ (&&/unwrap-long *writer*)] -;; _ (compile ?shift) -;; :let [_ (doto *writer* -;; &&/unwrap-long -;; (.visitInsn Opcodes/L2I))] -;; :let [_ (doto *writer* -;; (.visitInsn ) -;; &&/wrap-long)]] -;; (return nil))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (compile ?input) + =param (compile ?param)] + (return (str "LuxRT." "(" =input "," =param ".L)")))) + + ^:private compile-bit-shift-left "shlI64" + ^:private compile-bit-shift-right "shrI64" + ^:private compile-bit-unsigned-shift-right "ushlI64" + ) -;; ^:private compile-bit-shift-left Opcodes/LSHL -;; ^:private compile-bit-shift-right Opcodes/LSHR -;; ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR -;; ) +(defn ^:private compile-bit-count [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (compile ?input)] + (return (str "LuxRT.countI64(" =input ")")))) (defn ^:private compile-lux-is [compile ?values special-args] (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] @@ -488,15 +468,15 @@ "contains?" (compile-text-contains? compile ?values special-args) ) - ;; "bit" - ;; (case proc - ;; "count" (compile-bit-count compile ?values special-args) - ;; "and" (compile-bit-and compile ?values special-args) - ;; "or" (compile-bit-or compile ?values special-args) - ;; "xor" (compile-bit-xor compile ?values special-args) - ;; "shift-left" (compile-bit-shift-left compile ?values special-args) - ;; "shift-right" (compile-bit-shift-right compile ?values special-args) - ;; "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) + "bit" + (case proc + "count" (compile-bit-count compile ?values special-args) + "and" (compile-bit-and compile ?values special-args) + "or" (compile-bit-or compile ?values special-args) + "xor" (compile-bit-xor compile ?values special-args) + "shift-left" (compile-bit-shift-left compile ?values special-args) + "shift-right" (compile-bit-shift-right compile ?values special-args) + "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args)) "array" (case proc diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index cc00e2908..2416445e5 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1304,6 +1304,77 @@ "})") }) +(def ^:private bit-methods + (let [make-basic-op (fn [op] + (str "(function andI64(input,mask) {" + "return LuxRT.makeI64(input.H " op " mask.H, input.L " op " mask.L);" + "})"))] + {"andI64" (make-basic-op "&") + "orI64" (make-basic-op "|") + "xorI64" (make-basic-op "^") + "countI64" (str "(function countI64(input) {" + "var hs = (input.H).toString(2);" + "var ls = (input.L).toString(2);" + "var num1s = hs.concat(ls).replace('0','').length;" + "return LuxRT.fromNumberI64(num1s);" + "})") + "shlI64" (str "(function shlI64(input,shift) {" + "shift &= 63;" + (str "if(shift === 0) {" + "return input;" + "}" + "else {" + (str "if (shift < 32) {" + "var high = (input.H << shift) | (input.L >>> (32 - shift));" + "var low = input.L << shift;" + "return LuxRT.makeI64(high, low);" + "}" + "else {" + "var high = (input.L << (shift - 32));" + "return LuxRT.makeI64(high, 0);" + "}") + "}") + "})") + "shrI64" (str "(function shrI64(input,shift) {" + "shift &= 63;" + (str "if(shift === 0) {" + "return input;" + "}" + "else {" + (str "if (shift < 32) {" + "var high = input.H >> shift;" + "var low = (input.L >>> shift) | (input.H << (32 - shift));" + "return LuxRT.makeI64(high, low);" + "}" + "else {" + "var low = (input.H >> (shift - 32));" + "var high = input.H >= 0 ? 0 : -1;" + "return LuxRT.makeI64(high, low);" + "}") + "}") + "})") + "ushrI64" (str "(function ushrI64(input,shift) {" + "shift &= 63;" + (str "if(shift === 0) {" + "return input;" + "}" + "else {" + (str "if (shift < 32) {" + "var high = input.H >>> shift;" + "var low = (input.L >>> shift) | (input.H << (32 - shift));" + "return LuxRT.makeI64(high, low);" + "}" + "else if(shift === 32) {" + "return LuxRT.makeI64(0, input.H);" + "}" + "else {" + "var low = (input.H >>> (shift - 32));" + "return LuxRT.makeI64(0, low);" + "}") + "}") + "})") + })) + (def LuxRT "LuxRT") (def compile-LuxRT @@ -1313,6 +1384,7 @@ n64-methods text-methods array-methods + bit-methods io-methods) (map (fn [[key val]] (str key ":" val))) -- cgit v1.2.3 From d8bba8c477525a0e70eab4f289e043cfe352bd62 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 14:48:52 -0400 Subject: - Implemented math procedures for JS. - Degree<->radian conversions are no longer math procedures. --- luxc/src/lux/analyser/proc/common.clj | 4 -- luxc/src/lux/compiler/js/proc/common.clj | 68 +++++++++++++++++++++++++++++++ luxc/src/lux/compiler/jvm/proc/common.clj | 4 -- 3 files changed, 68 insertions(+), 8 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index c91074676..050877ed5 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -391,8 +391,6 @@ ^:private analyse-math-log "log" ^:private analyse-math-root2 "root2" ^:private analyse-math-root3 "root3" - ^:private analyse-math-degrees "degrees" - ^:private analyse-math-radians "radians" ^:private analyse-math-ceil "ceil" ^:private analyse-math-floor "floor" ^:private analyse-math-round "round" @@ -615,8 +613,6 @@ "log" (analyse-math-log analyse exo-type ?values) "root2" (analyse-math-root2 analyse exo-type ?values) "root3" (analyse-math-root3 analyse exo-type ?values) - "degrees" (analyse-math-degrees analyse exo-type ?values) - "radians" (analyse-math-radians analyse exo-type ?values) "ceil" (analyse-math-ceil analyse exo-type ?values) "floor" (analyse-math-floor analyse exo-type ?values) "round" (analyse-math-round analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 60ade9300..942f24c79 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -439,6 +439,50 @@ (str "LuxRT.toNumberI64(" =milliseconds ")") ")")))) +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return (str "Math." )))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (compile ?input)] + (return (str "Math." "(" =input ")")))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ^:private compile-math-round "round" + ) + +(do-template [ ] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (compile ?input) + =param (compile ?param)] + (return (str "Math." "(" =input "," =param ")")))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + (defn compile-proc [compile category proc ?values special-args] (case category "lux" @@ -566,6 +610,30 @@ "to-nat" (compile-char-to-nat compile ?values special-args) ) + "math" + (case proc + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) + "atom" (case proc "new" (compile-atom-new compile ?values special-args) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 6a952e6d3..b7e80dd2e 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -774,8 +774,6 @@ ^:private compile-math-log "log" ^:private compile-math-root2 "sqrt" ^:private compile-math-root3 "cbrt" - ^:private compile-math-degrees "toDegrees" - ^:private compile-math-radians "toRadians" ^:private compile-math-ceil "ceil" ^:private compile-math-floor "floor" ) @@ -1023,8 +1021,6 @@ "log" (compile-math-log compile ?values special-args) "root2" (compile-math-root2 compile ?values special-args) "root3" (compile-math-root3 compile ?values special-args) - "degrees" (compile-math-degrees compile ?values special-args) - "radians" (compile-math-radians compile ?values special-args) "ceil" (compile-math-ceil compile ?values special-args) "floor" (compile-math-floor compile ?values special-args) "round" (compile-math-round compile ?values special-args) -- cgit v1.2.3 From 78e43d0be6fac5b8513e9dc4081a10391632feaa Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 18:42:18 -0400 Subject: - Increased the fixpoints limit to 64. --- luxc/src/lux/type.clj | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index 854472c94..a0729f040 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -766,14 +766,14 @@ [(&/$AppT F A) _] (let [fp-pair (&/T [expected actual]) - _ (when (> (&/|length fixpoints) 40) - (println 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str ""))) + _ (when (> (&/|length fixpoints) 64) + (&/|log! (println-str 'FIXPOINTS (->> (&/|keys fixpoints) + (&/|map (fn [pair] + (|let [[e a] pair] + (str (show-type e) ":+:" + (show-type a))))) + (&/|interpose "\n\n") + (&/fold str "")))) (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] (|case (fp-get fp-pair fixpoints) (&/$Some ?) -- cgit v1.2.3 From 8fafa00056cbd4b0a3da77258e4d258a2f25767e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 18:48:33 -0400 Subject: - Implemented new IO procedures for JS. --- luxc/src/lux/compiler/js/proc/common.clj | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 942f24c79..a1b26a45b 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -392,6 +392,15 @@ =message (compile ?message)] (return (str "LuxRT.error(" =message ")")))) +(defn ^:private compile-io-exit [compile ?values special-args] + (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] + =code (compile ?code)] + (return (str "(process && process.exit && process.exit(LuxRT.fromNumberI64(" =code ")))")))) + +(defn ^:private compile-io-current-time [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return (str "LuxRT.toNumberI64(" "(new Date()).getTime()" ")")))) + (defn ^:private compile-atom-new [compile ?values special-args] (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] =init (compile ?init)] @@ -492,7 +501,9 @@ "io" (case proc "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args)) + "error" (compile-io-error compile ?values special-args) + "exit" (compile-io-exit compile ?values special-args) + "current-time" (compile-io-current-time compile ?values special-args)) "text" (case proc -- cgit v1.2.3 From 79c10caf4c7e370dc53c4c60c57cc16ccec48773 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 19:36:21 -0400 Subject: - Added a new try-catch procedure. --- luxc/src/lux/analyser/proc/common.clj | 15 ++++++++++++++- luxc/src/lux/compiler/jvm/proc/common.clj | 12 +++++++++++- luxc/src/lux/compiler/jvm/rt.clj | 23 +++++++++++++++++++++++ 3 files changed, 48 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 050877ed5..9a295b1eb 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -17,6 +17,18 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list))))))))) +(defn ^:private analyse-lux-try [analyse exo-type ?values] + (&type/with-var + (fn [$var] + (|do [:let [(&/$Cons op (&/$Nil)) ?values] + =op (&&/analyse-1 analyse (&/$AppT &type/IO $var) op) + _ (&type/check exo-type (&/$SumT &type/Text ;; lux;Left + $var ;; lux;Right + )) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) + (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] @@ -470,7 +482,8 @@ (case category "lux" (case proc - "is" (analyse-lux-is analyse exo-type ?values)) + "is" (analyse-lux-is analyse exo-type ?values) + "try" (analyse-lux-try analyse exo-type ?values)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index b7e80dd2e..d434e0365 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -179,6 +179,15 @@ (.visitLabel $end))]] (return nil))) +(defn ^:private compile-lux-try [compile ?values special-args] + (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?op) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "lux/Function") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]] + (return nil))) + (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -878,7 +887,8 @@ (case category "lux" (case proc - "is" (compile-lux-is compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args) + "try" (compile-lux-try compile ?values special-args)) "io" (case proc diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj index 0f86325f2..97c7d849c 100644 --- a/luxc/src/lux/compiler/jvm/rt.clj +++ b/luxc/src/lux/compiler/jvm/rt.clj @@ -1440,6 +1440,29 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) + _ (let [$from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") + (.visitLabel $from) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitInsn Opcodes/ACONST_NULL) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1)) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitLabel $to) + (.visitLabel $handler) ;; T + (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; TI + (.visitInsn Opcodes/ACONST_NULL) ;; TI? + swap2x1 ;; I?T + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;") ;; I?S + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) _ (doto =class (compile-LuxRT-pm-methods) (compile-LuxRT-adt-methods) -- cgit v1.2.3 From 2f77d20394274e89da509716b4cf78fba9724e46 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 26 Feb 2017 20:17:23 -0400 Subject: - Added try-catch procedure to JS backend. --- luxc/src/lux/compiler/js/proc/common.clj | 8 +++++++- luxc/src/lux/compiler/js/rt.clj | 14 +++++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index a1b26a45b..08bf94b04 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -49,6 +49,11 @@ =right (compile ?right)] (return (str "(" =left " === " =right ")")))) +(defn ^:private compile-lux-try [compile ?values special-args] + (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] + =op (compile ?op)] + (return (str "LuxRT.runTry(" =op ")")))) + (defn ^:private compile-array-new [compile ?values special-args] (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] =length (compile ?length)] @@ -496,7 +501,8 @@ (case category "lux" (case proc - "is" (compile-lux-is compile ?values special-args)) + "is" (compile-lux-is compile ?values special-args) + "try" (compile-lux-try compile ?values special-args)) "io" (case proc diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 2416445e5..e6a50b373 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1375,11 +1375,23 @@ "})") })) +(def ^:private lux-methods + {"runTry" (str "(function runTry(op) {" + (str "try {" + (str "return [1,'',op(null)];") + "}" + "catch(ex) {" + (str "return [0,null,ex.toString()];") + "}") + "})") + }) + (def LuxRT "LuxRT") (def compile-LuxRT (|do [_ (&&/run-js! "var console = { log: print };") - :let [rt-object (str "{" (->> (merge adt-methods + :let [rt-object (str "{" (->> (merge lux-methods + adt-methods i64-methods n64-methods text-methods -- cgit v1.2.3 From 9dc39d70349707d6fb4db444db3795e5c9ed86dd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Feb 2017 00:22:38 -0400 Subject: - Now accepting JS objects as valid values (necessary for objects encoding atoms). --- luxc/src/lux/compiler/js/base.clj | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index c6a6f538c..8daec05c5 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -187,7 +187,9 @@ (decode-char js-object) :else - (assert false (str "Unknown kind of JS object: " js-object)))) + js-object + ;; (assert false (str "Unknown kind of JS object: " js-object)) + )) :else (assert false (str "Unknown kind of JS object: " (class js-object) " :: " js-object)))) -- cgit v1.2.3 From 64ddf4b17c06703cf04d8f20da12abd8922ed679 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Feb 2017 00:26:40 -0400 Subject: - Fixed some bugs when compiling common procedures in JS. --- luxc/src/lux/compiler/js/proc/common.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 08bf94b04..c7e741e01 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -35,7 +35,7 @@ ^:private compile-bit-shift-left "shlI64" ^:private compile-bit-shift-right "shrI64" - ^:private compile-bit-unsigned-shift-right "ushlI64" + ^:private compile-bit-unsigned-shift-right "ushrI64" ) (defn ^:private compile-bit-count [compile ?values special-args] @@ -89,7 +89,7 @@ ;; (&/$Nil) special-args ] =array (compile ?array)] - (return (str =array ".length")))) + (return (str "LuxRT.fromNumberI64(" =array ".length" ")")))) (do-template [ ] (defn [compile ?values special-args] -- cgit v1.2.3 From 56f051d1429e4c46f184e3637341ee9c572fe59e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Feb 2017 00:27:33 -0400 Subject: - Implemented degree encoding. --- luxc/src/lux/compiler/js/rt.clj | 299 ++++++++-------------------------------- 1 file changed, 54 insertions(+), 245 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index e6a50b373..e9dfa451b 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -45,18 +45,6 @@ ;; (.visitInsn Opcodes/POP2) ;; Y2, X1 ;; )) -;; (defn ^:private bit-set-64? [^MethodVisitor =method] -;; (doto =method -;; ;; L, I -;; (.visitLdcInsn (long 1)) ;; L, I, L -;; (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L -;; (.visitInsn Opcodes/POP2) ;; L, L, I -;; (.visitInsn Opcodes/LSHL) ;; L, L -;; (.visitInsn Opcodes/LAND) ;; L -;; (.visitLdcInsn (long 0)) ;; L, L -;; (.visitInsn Opcodes/LCMP) ;; I -;; )) - ;; (defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] ;; (|let [deg-bits 64 ;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) @@ -148,239 +136,6 @@ ;; (.visitMaxs 0 0) ;; (.visitEnd)) ;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil) -;; (.visitCode) -;; (.visitLdcInsn (int 0)) ;; {carry} -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 0) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; {carry} -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 0) -;; (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit} -;; (.visitLdcInsn (int 5)) -;; (.visitInsn Opcodes/IMUL) -;; (.visitInsn Opcodes/IADD) ;; {next-raw-digit} -;; (.visitInsn Opcodes/DUP) -;; (.visitLdcInsn (int 10)) -;; (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit} -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 0) -;; swap2x1 -;; (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit} -;; (.visitLdcInsn (int 10)) -;; (.visitInsn Opcodes/IDIV) ;; {next-carry} -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 0) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil) -;; (.visitCode) -;; ;; Initialize digits array. -;; (.visitLdcInsn (int deg-bits)) -;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits} -;; (.visitInsn Opcodes/DUP) -;; (.visitVarInsn Opcodes/ILOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/BASTORE) ;; digits = 5^0 -;; (.visitVarInsn Opcodes/ASTORE 1) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitVarInsn Opcodes/ILOAD 0) ;; {times} -;; (.visitLabel $loop-start) -;; (.visitInsn Opcodes/DUP) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; ;; {times} -;; (.visitVarInsn Opcodes/ILOAD 0) -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times} -;; (.visitVarInsn Opcodes/ASTORE 1) ;; {times} -;; ;; Decrement index -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; ;; {times-1} -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil) -;; (.visitCode) -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index -;; (.visitLdcInsn (int deg-bits)) -;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) -;; (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits -;; (.visitLdcInsn (int 0)) ;; {carry} -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; {carry} -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; ;; {carry} -;; (.visitVarInsn Opcodes/ALOAD 3) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; {carry} -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/BALOAD) ;; {carry, dL} -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR} -;; (.visitInsn Opcodes/IADD) -;; (.visitInsn Opcodes/IADD) ;; {raw-next-digit} -;; (.visitInsn Opcodes/DUP) -;; (.visitLdcInsn (int 10)) -;; (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit} -;; (.visitVarInsn Opcodes/ALOAD 3) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; swap2x1 -;; (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit} -;; (.visitLdcInsn (int 10)) -;; (.visitInsn Opcodes/IDIV) ;; {next-carry} -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 2) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil) -;; (.visitCode) -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index -;; (.visitLdcInsn "") ;; {text} -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitInsn Opcodes/BALOAD) ;; {text, digit} -;; (.visitLdcInsn (int 10)) ;; {text, digit, radix} -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char} -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text} -;; (.visitInsn Opcodes/SWAP) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 1) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label) -;; $not-set (new Label) -;; $next-iteration (new Label) -;; $normal-path (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil) -;; (.visitCode) -;; ;; A quick corner-case to handle. -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFNE $normal-path) -;; (.visitLdcInsn ".0") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitLabel $normal-path) -;; ;; Normal case -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index -;; (.visitLdcInsn (int deg-bits)) -;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) -;; (.visitVarInsn Opcodes/ASTORE 3) ;; digits -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; ;; Prepare text to return. -;; (.visitVarInsn Opcodes/ALOAD 3) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;") -;; (.visitLdcInsn ".") -;; (.visitInsn Opcodes/SWAP) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") -;; ;; Trim unnecessary 0s at the end... -;; (.visitLdcInsn "0*$") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") -;; (.visitLdcInsn (int 0)) -;; (.visitInsn Opcodes/AALOAD) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; bit-set-64? -;; (.visitJumpInsn Opcodes/IFEQ $next-iteration) -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/ISUB) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") -;; (.visitVarInsn Opcodes/ALOAD 3) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B") -;; (.visitVarInsn Opcodes/ASTORE 3) -;; (.visitJumpInsn Opcodes/GOTO $next-iteration) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $next-iteration) -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 2) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) ;; $do-a-round (new Label) ;; $not-set (new Label) ;; $next-iteration (new Label)] @@ -1217,6 +972,59 @@ "})") }) +(def ^:private d64-methods + {"_add_deg_digit_powers" (str "(function _add_deg_digit_powers(left,right) {" + "var output = new Array(64);" + "var carry = 0;" + (str "for(var idx = 63; idx >= 0; idx--) {" + "var raw = left[idx] + right[idx] + carry;" + "output[idx] = raw % 10;" + "raw = (raw / 10)|0;" + "}") + "return output;" + "})") + "_times5" (str "(function _times5(exp,digits) {" + "var carry = 0;" + (str "for(var idx = exp; idx >= 0; idx--) {" + "var raw = (digits[exp] * 5) + carry;" + "digits[exp] = raw % 10;" + "carry = (raw / 10)|0;" + "}") + "return digits;" + "})") + "_deg_digit_power" (str "(function _deg_digit_power(exp) {" + "var digits = new Array(64);" + "digits[exp] = 1;" + (str "for(var idx = exp; idx >= 0; idx--) {" + "digits = LuxRT._times5(exp,digits);" + "}") + "return digits;" + "})") + "_bitIsSet" (str "(function _bitIsSet(input,idx) {" + "idx &= 63;" + (str "if(idx < 32) {" + "return (input.L & (1 << idx)) !== 0;" + "}") + (str "else {" + "return (input.H & (1 << (idx - 32))) !== 0;" + "}") + "})") + "encodeD64" (str "(function encodeD64(input) {" + (str "if(LuxRT.eqI64(input,LuxRT.ZERO)) {" + "return '.0';" + "}") + "var digits = new Array(64);" + (str "for(var idx = 63; idx >= 0; idx--) {" + (str "if(LuxRT._bitIsSet(input,idx)) {" + "var power = LuxRT._deg_digit_power(63 - idx);" + "digits = LuxRT._add_deg_digit_powers(digits,power);" + "}") + "}") + "var raw = '.'.concat(digits.join(''));" + "return raw.split(/0*$/)[0];" + "})") + }) + (def ^:private io-methods {"log" (str "(function log(message) {" "console.log(message);" @@ -1394,6 +1202,7 @@ adt-methods i64-methods n64-methods + d64-methods text-methods array-methods bit-methods -- cgit v1.2.3 From e35651387f0c18256ab704af4f62e454d75b5968 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Feb 2017 18:53:07 -0400 Subject: - Fixed a bug when compiling pattern-matching comparisons for several types. --- luxc/src/lux/compiler/js/lux.clj | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 4e7ddd8fd..2de9eeec1 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -178,19 +178,22 @@ (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$NatPM _value) - (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) + (|do [=value (compile-nat _value)] + (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) (&o/$IntPM _value) - (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) + (|do [=value (compile-int _value)] + (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) (&o/$DegPM _value) - (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) + (|do [=value (compile-deg _value)] + (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) (&o/$RealPM _value) (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$CharPM _value) - (return (str "if(" cursor-peek " !== " (pr-str (str _value)) ") { " pm-fail " }")) + (return (str "if(" (str "(" cursor-peek ").C") " !== " (pr-str (str _value)) ") { " pm-fail " }")) (&o/$TextPM _value) (return (str "if(" cursor-peek " !== " (pr-str _value) ") { " pm-fail " }")) -- cgit v1.2.3 From 19eb25c2f1263988f67ff72f632dea50b8e3f8dd Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 27 Feb 2017 18:54:25 -0400 Subject: - console.log is now defined when starting compilation, and not when LuxRT is compiled, to avoid issues when compiling a partially-cached program. --- luxc/src/lux/compiler/js.clj | 3 ++- luxc/src/lux/compiler/js/rt.clj | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index b43ab5b4d..fa4bf9518 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -161,7 +161,8 @@ (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] (do (init! resources-dir target-dir) - (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs + (let [m-action (|do [_ (&&/run-js! "var console = { log: print };") + _ (&&cache/pre-load-cache! source-dirs &&js-cache/load-def-value &&js-cache/install-all-defs-in-module &&js-cache/uninstall-all-defs-in-module) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index e9dfa451b..b1c1aeb1b 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1197,8 +1197,7 @@ (def LuxRT "LuxRT") (def compile-LuxRT - (|do [_ (&&/run-js! "var console = { log: print };") - :let [rt-object (str "{" (->> (merge lux-methods + (|do [:let [rt-object (str "{" (->> (merge lux-methods adt-methods i64-methods n64-methods -- cgit v1.2.3 From 71ce7d944f40b0533c7774aaf75712f1c09afd0b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 28 Feb 2017 19:00:53 -0400 Subject: - Fixed some bugs when compiling pattern-matching. --- luxc/src/lux/compiler/js/lux.clj | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 2de9eeec1..e0d5a4247 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -33,8 +33,8 @@ (do-template [] (defn [value] - (let [high (-> value (unsigned-bit-shift-right 32) (bit-and mask-4b)) - low (-> value (bit-and mask-4b))] + (let [high (-> value (bit-shift-right 32) int) + low (-> value (bit-and mask-4b) (bit-shift-left 32) (bit-shift-right 32) int)] (return (str &&rt/LuxRT "." "makeI64" "(" high "," low ")")))) compile-nat @@ -179,24 +179,26 @@ (&o/$NatPM _value) (|do [=value (compile-nat _value)] - (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$IntPM _value) (|do [=value (compile-int _value)] - (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$DegPM _value) (|do [=value (compile-deg _value)] - (return (str "if(" (str "LuxRT.eqI64(" cursor-peek "," _value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$RealPM _value) (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) (&o/$CharPM _value) - (return (str "if(" (str "(" cursor-peek ").C") " !== " (pr-str (str _value)) ") { " pm-fail " }")) + (|do [=value (compile-char _value)] + (return (str "if(" (str "(" cursor-peek ").C") " !== " (str "(" =value ").C") ") { " pm-fail " }"))) (&o/$TextPM _value) - (return (str "if(" cursor-peek " !== " (pr-str _value) ") { " pm-fail " }")) + (|do [=value (compile-text _value)] + (return (str "if(" cursor-peek " !== " =value ") { " pm-fail " }"))) (&o/$TuplePM _idx+) (|let [[_idx is-tail?] (|case _idx+ -- cgit v1.2.3 From 27648dd619f1764ba58ca244e9fd0b017665058d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 2 Mar 2017 18:09:03 -0400 Subject: - Fixed a bug in which the value of a loop wasn't being returned. --- luxc/src/lux/compiler/js/lux.clj | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index e0d5a4247..5c6039d2b 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -91,7 +91,7 @@ register-inits (&/map% compile inits) =body (compile body)] (return (str "(function _loop(" (->> registers (&/|interpose ",") (&/fold str "")) ") {" - =body + (str "return " =body ";") "})(" (->> register-inits (&/|interpose ",") (&/fold str "")) ")")) )) @@ -343,9 +343,7 @@ _ false) - def-type (&a/expr-type* ?body) - ;; _ (&/|log! (string/replace def-js "" "^@")) - ] + def-type (&a/expr-type* ?body)] _ (&&/save-js! ?name def-js) def-value (&&/run-js!+ var-name) _ (&/without-repl-closure -- cgit v1.2.3 From 2bd7d936e0ca47e445c7d946aa1ae8287a62f049 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 5 Mar 2017 14:54:20 -0400 Subject: - Added temporary implementations for Nat division and remainder. - Fixed a bug in the RT function for counting bits. --- luxc/src/lux/compiler/js/rt.clj | 41 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index b1c1aeb1b..0c34453f7 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -965,6 +965,45 @@ "return '+'.concat(LuxRT.encodeI64(input));" "}") "})") + "divN64" (str "(function divN64(l,r) {" + (str "if(LuxRT.ltI64(r,LuxRT.ZERO)) {" + (str "if(LuxRT.ltN64(l,r)) {" + "return LuxRT.ZERO;" + "}" + "else {" + "return LuxRT.ONE;" + "}") + "}" + "else if(LuxRT.ltI64(LuxRT.ZERO,l)) {" + "return LuxRT.divI64(l,r);" + "}" + "else {" + (str "if(LuxRT.eqI64(LuxRT.ZERO,r)) {" + "throw new Error('Cannot divide by zero!');" + "}" + "else {" + (str "if(LuxRT.ltI64(l,r)) {" + "return LuxRT.ZERO;" + "}" + "else {" + "throw new Error('AWAITING BIG-INT DIVISION IMPLEMENTATION!!!');" + "}") + "}") + "}") + "})") + "remN64" (str "(function remN64(l,r) {" + (str "if(LuxRT.ltI64(l,LuxRT.ZERO) || LuxRT.ltI64(r,LuxRT.ZERO)) {" + (str "if(LuxRT.ltN64(l,r)) {" + "return l;" + "}" + "else {" + "throw new Error('AWAITING BIG-INT REMAINDER IMPLEMENTATION!!!');" + "}") + "}" + "else {" + "return LuxRT.remI64(l,r);" + "}") + "})") "ltN64" (str "(function ltN64(l,r) {" "var li = LuxRT.addI64(l,LuxRT.MIN_VALUE_I64);" "var ri = LuxRT.addI64(r,LuxRT.MIN_VALUE_I64);" @@ -1123,7 +1162,7 @@ "countI64" (str "(function countI64(input) {" "var hs = (input.H).toString(2);" "var ls = (input.L).toString(2);" - "var num1s = hs.concat(ls).replace('0','').length;" + "var num1s = hs.concat(ls).replace(/0/g,'').length;" "return LuxRT.fromNumberI64(num1s);" "})") "shlI64" (str "(function shlI64(input,shift) {" -- cgit v1.2.3 From a902bbaaceccb11316c6804c459181f62ce7e6a9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Mar 2017 18:20:22 -0400 Subject: - Now resetting the mappings of the type-vars to avoid having undead type-vars interfering with compilation. --- luxc/src/lux/analyser/lux.clj | 8 +++++++- luxc/src/lux/type.clj | 14 +++++++++++--- 2 files changed, 18 insertions(+), 4 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index aee46a9cc..304705331 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -559,7 +559,13 @@ ==meta (eval! (optimize =meta)) _ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value)) _ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value)) - _ (compile-def ?name (optimize =value) ==meta)] + _ (compile-def ?name (optimize =value) ==meta) + ;; TODO: Make the call to &type/reset-mappings unnecessary. + ;; It shouldn't be necessary to reset the mappings of the + ;; type-vars, because those mappings shouldn't stay around + ;; after being cleaned-up. + ;; I must figure out why they're staying around. + _ &type/reset-mappings] (return &/$Nil)) ))) diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index a0729f040..dd2e536bb 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -215,7 +215,7 @@ (&/$None) (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil)) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -225,7 +225,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/$Some type) %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -235,7 +235,7 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id &/$None %) - ts)) + ts)) state) nil) ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length))) @@ -243,6 +243,14 @@ ;; [Exports] ;; Type vars +(def reset-mappings + (fn [state] + (return* (&/update$ &/$type-vars #(->> % + ;; (&/set$ &/$counter 0) + (&/set$ &/$mappings (&/|table))) + state) + nil))) + (def create-var (fn [state] (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] -- cgit v1.2.3 From da8163b89261f19c26a76bf0204e735f6f6a0f21 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Mar 2017 18:21:41 -0400 Subject: - Turned the wrapper for chars into a type, for detection when transforming values from JS to Lux. - Now replacing dashes for underscores in module names during compilation. --- luxc/src/lux/compiler/js/base.clj | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 8daec05c5..417b35d5a 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -84,14 +84,14 @@ ;; else (assert false (str "I64#getMember = " member))))) -(defn ^:private encode-char [value] - (reify JSObject - (getMember [self member] - (condp = member - "C" value - ;; "toString" (_toString_simple value) - ;; else - (assert false (str "encode-char#getMember = " member)))))) +(deftype EncChar [value] + JSObject + (getMember [self member] + (condp = member + "C" value + ;; "toString" (_toString_simple value) + ;; else + (assert false (str "EncChar#getMember = " member))))) (deftype LuxJsObject [^"[Ljava.lang.Object;" obj] JSObject @@ -105,7 +105,7 @@ (new I64 value) (instance? java.lang.Character value) - (encode-char (str value)) + (new EncChar (str value)) :else value))) @@ -156,6 +156,9 @@ (instance? I64 js-object) (.-value ^I64 js-object) + (instance? EncChar js-object) + (.charAt ^String (.-value ^EncChar js-object) 0) + ;; (instance? Undefined js-object) ;; (assert false "UNDEFINED") @@ -222,7 +225,9 @@ (return nil))) (defn js-module [module] - (string/replace module "/" "$")) + (-> module + (string/replace "/" "$") + (string/replace "-" "_"))) (defn js-var-name [module name] (str (js-module module) "$" (&host/def-name name))) -- cgit v1.2.3 From cb397b69bf5c5739353bffa938d74c3f2d404a02 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 11 Mar 2017 19:32:42 -0400 Subject: - Partially implemented natural division and remainder. - Fixed a bug in the sum_get RT function. - Implemented decoding for integers. - Fixed some bugs in LuxRT functions. --- luxc/src/lux/compiler/js/rt.clj | 227 +++++++++++----------------------------- 1 file changed, 62 insertions(+), 165 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 0c34453f7..0ece93d6e 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -519,137 +519,13 @@ ;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") ;; (.visitInsn Opcodes/ARETURN) ;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 -;; _ (let [$simple-case (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil) -;; (.visitCode) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFGE $simple-case) -;; ;; else -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LUSHR) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") -;; (.visitLdcInsn (int 32)) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;") -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LSHL) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LUSHR) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; then -;; (.visitLabel $simple-case) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 -;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil) -;; (.visitCode) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") -;; (.visitInsn Opcodes/LADD) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J") -;; (.visitInsn Opcodes/LADD) -;; (.visitInsn Opcodes/LCMP) -;; (.visitInsn Opcodes/IRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 -;; _ (let [$case-1 (new Label) -;; $0 (new Label) -;; $case-2 (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil) -;; (.visitCode) -;; ;; Test #1 -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFLT $case-1) -;; ;; Test #2 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFGT $case-2) -;; ;; Case #3 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") -;; (.visitInsn Opcodes/LRETURN) -;; ;; Case #2 -;; (.visitLabel $case-2) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitInsn Opcodes/LDIV) -;; (.visitInsn Opcodes/LRETURN) -;; ;; Case #1 -;; (.visitLabel $case-1) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitJumpInsn Opcodes/IFLT $0) -;; ;; 1 -;; (.visitLdcInsn (long 1)) -;; (.visitInsn Opcodes/LRETURN) -;; ;; 0 -;; (.visitLabel $0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 -;; _ (let [$test-2 (new Label) -;; $case-2 (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil) -;; (.visitCode) -;; ;; Test #1 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFLE $test-2) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitLdcInsn (long 0)) -;; (.visitInsn Opcodes/LCMP) -;; (.visitJumpInsn Opcodes/IFLE $test-2) -;; ;; Case #1 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitInsn Opcodes/LREM) -;; (.visitInsn Opcodes/LRETURN) -;; ;; Test #2 -;; (.visitLabel $test-2) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitJumpInsn Opcodes/IFLT $case-2) -;; ;; Case #3 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J") -;; (.visitInsn Opcodes/LRETURN) -;; ;; Case #2 -;; (.visitLabel $case-2) -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitInsn Opcodes/LRETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitMaxs 0 0) ;; (.visitEnd)))] ;; nil))) +(def ^:private const-none (str "[0,null," &&/unit "]")) +(defn ^:private make-some [value] + (str "[1,''," value "]")) + (def ^:private adt-methods {"product_getLeft" (str "(function product_getLeft(product,index) {" "var index_min_length = (index+1);" @@ -677,22 +553,21 @@ "return product.slice(index);" "}" "})") - "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "sum_get" (let [no-match "return null;" + extact-match "return sum[2];" + recursion-test (str (str "if(sum[1] === '') {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + "else { " no-match " }"))] + (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(wantedTag === sum[0]) {" + (str "if(sum[1] === wantsLast) {" extact-match "}" + "else {" recursion-test "}") + "}" + "else if(wantedTag > sum[0]) {" recursion-test "}" + "else { " no-match " }" + "})")) }) (def ^:private i64-methods @@ -906,6 +781,13 @@ "remI64" (str "(function remI64(l,r) {" "return LuxRT.subI64(l,LuxRT.mulI64(LuxRT.divI64(l,r),r));" "})") + "ltI64" (str "(function ltI64(l,r) {" + "var ln = l.H < 0;" + "var rn = r.H < 0;" + "if(ln && !rn) { return true; }" + "if(!ln && rn) { return false; }" + "return (LuxRT.subI64(l,r).H < 0);" + "})") "encodeI64" (str "(function encodeI64(input) {" ;; If input = 0 (str "if((input.H === 0) && (input.L === 0)) {" @@ -943,13 +825,33 @@ "}")) "}") "})") - "ltI64" (str "(function ltI64(l,r) {" - "var ln = l.H < 0;" - "var rn = r.H < 0;" - "if(ln && !rn) { return true; }" - "if(!ln && rn) { return false; }" - "return (LuxRT.subI64(l,r).H < 0);" - "})") + "decodeI64" (str "(function decodeI64(input) {" + (str "if(/^-?\\d+$/.exec(input)) {" + (str "var isNegative = (input.charAt(0) == '-');" + "var sign = isNegative ? -1 : 1;" + "input = isNegative ? input.substring(1) : input;" + + "var chunkPower = LuxRT.fromNumberI64(Math.pow(10, 8));" + "var result = LuxRT.ZERO;" + (str "for (var i = 0; i < input.length; i += 8) {" + "var size = Math.min(8, input.length - i);" + "var value = parseInt(input.substring(i, i + size), 10);" + (str "if (size < 8) {" + "var power = LuxRT.fromNumberI64(Math.pow(10, size));" + "result = LuxRT.addI64(LuxRT.mulI64(result,power),LuxRT.fromNumberI64(value));" + "}" + "else {" + "result = LuxRT.addI64(LuxRT.mulI64(result,chunkPower),LuxRT.fromNumberI64(value));" + "}") + "}") + "result = LuxRT.mulI64(result,LuxRT.fromNumberI64(sign));" + (str "return " (make-some "result") ";") + ) + "}" + "else {" + (str "return " const-none ";") + "}") + "})") }) (def ^:private n64-methods @@ -1075,10 +977,6 @@ "})") }) -(def ^:private const-none (str "[0,null," &&/unit "]")) -(defn ^:private make-some [value] - (str "[1,''," value "]")) - (def ^:private text-methods {"index" (str "(function index(text,part,start) {" "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" @@ -1099,25 +997,24 @@ "}")) "})") "clip" (str "(function clip(text,from,to) {" - "var clip = text.substring(from.L,to.L);" - (str (str "if(clip === '') {" - "return " const-none ";" - "}") - (str "else {" - "return " (make-some "clip") ";" - "}")) + (str "if(from.L > text.length || to.L > text.length) {" + (str "return " const-none ";") + "}" + "else {" + (str "return " (make-some "text.substring(from.L,to.L)") ";") + "}") "})") "replaceAll" (str "(function replaceAll(text,toFind,replaceWith) {" "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") "textChar" (str "(function textChar(text,idx) {" - "var result = text.charAt(idx);" + "var result = text.charAt(idx.L);" (str "if(result === '') {" - (str "return " (make-some "result") ";") + (str "return " const-none ";") "}" "else {" - (str "return " const-none ";") + (str "return " (make-some "{'C':result}") ";") "}") "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" -- cgit v1.2.3 From 913062dd2bc8559c44e0f07cdece404cc7f6791c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Mar 2017 20:16:34 -0400 Subject: - Implemented natural decoding. - Implemented the _lux_program statement. --- luxc/src/lux/compiler/js/lux.clj | 83 +++-------------------- luxc/src/lux/compiler/js/rt.clj | 138 ++++++++++----------------------------- 2 files changed, 44 insertions(+), 177 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 5c6039d2b..ffb75a3ef 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -381,78 +381,11 @@ ) (defn compile-program [compile ?body] - (assert false "compile-program") - ;; (|do [module-name &/get-module-name - ;; ^ClassWriter *writer* &/get-writer] - ;; (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) - ;; (.visitCode)) - ;; (|do [^MethodVisitor main-writer &/get-writer - ;; :let [$loop (new Label) - ;; $end (new Label) - ;; _ (doto main-writer - ;; ;; Tail: Begin - ;; (.visitLdcInsn (->> #'&/$Nil meta ::&/idx int)) ;; I - ;; (.visitInsn Opcodes/ACONST_NULL) ;; I? - ;; (.visitLdcInsn &/unit-tag) ;; I?U - ;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V - ;; ;; Tail: End - ;; ;; Size: Begin - ;; (.visitVarInsn Opcodes/ALOAD 0) ;; VA - ;; (.visitInsn Opcodes/ARRAYLENGTH) ;; VI - ;; ;; Size: End - ;; ;; Loop: Begin - ;; (.visitLabel $loop) - ;; (.visitLdcInsn (int 1)) ;; VII - ;; (.visitInsn Opcodes/ISUB) ;; VI - ;; (.visitInsn Opcodes/DUP) ;; VII - ;; (.visitJumpInsn Opcodes/IFLT $end) ;; VI - ;; ;; Head: Begin - ;; (.visitInsn Opcodes/DUP) ;; VII - ;; (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA - ;; (.visitInsn Opcodes/SWAP) ;; VIAI - ;; (.visitInsn Opcodes/AALOAD) ;; VIO - ;; (.visitInsn Opcodes/SWAP) ;; VOI - ;; (.visitInsn Opcodes/DUP_X2) ;; IVOI - ;; (.visitInsn Opcodes/POP) ;; IVO - ;; ;; Head: End - ;; ;; Tuple: Begin - ;; (.visitLdcInsn (int 2)) ;; IVOS - ;; (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 - ;; (.visitInsn Opcodes/DUP_X1) ;; IV2O2 - ;; (.visitInsn Opcodes/SWAP) ;; IV22O - ;; (.visitLdcInsn (int 0)) ;; IV22OI - ;; (.visitInsn Opcodes/SWAP) ;; IV22IO - ;; (.visitInsn Opcodes/AASTORE) ;; IV2 - ;; (.visitInsn Opcodes/DUP_X1) ;; I2V2 - ;; (.visitInsn Opcodes/SWAP) ;; I22V - ;; (.visitLdcInsn (int 1)) ;; I22VI - ;; (.visitInsn Opcodes/SWAP) ;; I22IV - ;; (.visitInsn Opcodes/AASTORE) ;; I2 - ;; ;; Tuple: End - ;; ;; Cons: Begin - ;; (.visitLdcInsn (->> #'&/$Cons meta ::&/idx int)) ;; I2I - ;; (.visitLdcInsn "") ;; I2I? - ;; (.visitInsn Opcodes/DUP2_X1) ;; II?2I? - ;; (.visitInsn Opcodes/POP2) ;; II?2 - ;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV - ;; ;; Cons: End - ;; (.visitInsn Opcodes/SWAP) ;; VI - ;; (.visitJumpInsn Opcodes/GOTO $loop) - ;; ;; Loop: End - ;; (.visitLabel $end) ;; VI - ;; (.visitInsn Opcodes/POP) ;; V - ;; (.visitVarInsn Opcodes/ASTORE (int 0)) ;; - ;; ) - ;; ] - ;; _ (compile ?body) - ;; :let [_ (doto main-writer - ;; (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - ;; (.visitInsn Opcodes/ACONST_NULL) - ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - ;; :let [_ (doto main-writer - ;; (.visitInsn Opcodes/POP) - ;; (.visitInsn Opcodes/RETURN) - ;; (.visitMaxs 0 0) - ;; (.visitEnd))]] - ;; (return nil)))) - ) + (|do [=body (compile ?body) + :let [program-js (str (str "var " (register-name 0) " = LuxRT.programArgs();") + (str "(" =body ")(null);"))] + eval? &/get-eval + ^StringBuilder buffer &&/get-buffer + :let [_ (when (not eval?) + (.append buffer ^String (str program-js "\n")))]] + (return ""))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 0ece93d6e..c022dd3bb 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -420,108 +420,6 @@ ;; (.visitEnd)))] ;; nil)) -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] -;; (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class] -;; (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677 -;; _ (let [$from (new Label) -;; $to (new Label) -;; $handler (new Label) - -;; $good-start (new Label) -;; $short-enough (new Label) -;; $bad-digit (new Label) -;; $out-of-bounds (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) -;; (.visitCode) -;; (.visitTryCatchBlock $from $to $handler "java/lang/Exception") -;; (.visitLabel $from) -;; ;; Remove the + at the beginning... -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitLdcInsn (int 0)) -;; (.visitLdcInsn (int 1)) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") -;; (.visitLdcInsn "+") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") -;; (.visitJumpInsn Opcodes/IFNE $good-start) -;; ;; Doesn't start with + -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; Starts with + -;; (.visitLabel $good-start) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") -;; (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix... -;; ;; Begin parsing processs -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitLdcInsn (int 18)) -;; (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough) -;; ;; Too long -;; ;; Get prefix... -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitLdcInsn (int 0)) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") -;; (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later... -;; ;; Get last digit... -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") -;; (.visitLdcInsn (int 10)) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I") -;; ;; Test last digit... -;; (.visitInsn Opcodes/DUP) -;; (.visitJumpInsn Opcodes/IFLT $bad-digit) -;; ;; Good digit... -;; ;; Stack: prefix::L, prefix::L, last-digit::I -;; (.visitInsn Opcodes/I2L) -;; ;; Build the result... -;; swap2 -;; (.visitLdcInsn (long 10)) -;; (.visitInsn Opcodes/LMUL) -;; (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L -;; (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L -;; swap2 ;; Stack: result::L, result::L, prefix::L -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitJumpInsn Opcodes/IFLT $out-of-bounds) -;; ;; Within bounds -;; ;; Stack: result::L -;; &&/wrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; Out of bounds -;; (.visitLabel $out-of-bounds) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; Bad digit... -;; (.visitLabel $bad-digit) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;; 18 chars or less -;; (.visitLabel $short-enough) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J") -;; &&/wrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitLabel $to) -;; (.visitLabel $handler) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)))] -;; nil))) - (def ^:private const-none (str "[0,null," &&/unit "]")) (defn ^:private make-some [value] (str "[1,''," value "]")) @@ -867,6 +765,30 @@ "return '+'.concat(LuxRT.encodeI64(input));" "}") "})") + "decodeN64" (str "(function decodeN64(input) {" + (str "if(/^\\+\\d+$/.exec(input)) {" + (str "input = input.substring(1);") + (str "if(input.length <= 18) {" + ;; Short enough... + "return LuxRT.decodeI64(input);" + "}" + "else {" + ;; Too long + (str "var prefix = LuxRT.decodeI64(input.substring(0, input.length-1))[2];" + "var suffix = LuxRT.decodeI64(input.charAt(input.length-1))[2];" + "var total = LuxRT.addI64(LuxRT.mulI64(prefix,LuxRT.fromNumberI64(10)),suffix);" + (str "if(LuxRT.ltN64(total,prefix)) {" + (str "return " const-none ";") + "}" + "else {" + (str "return " (make-some "total") ";") + "}")) + "}") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") "divN64" (str "(function divN64(l,r) {" (str "if(LuxRT.ltI64(r,LuxRT.ZERO)) {" (str "if(LuxRT.ltN64(l,r)) {" @@ -1128,6 +1050,18 @@ (str "return [0,null,ex.toString()];") "}") "})") + "programArgs" (str "(function programArgs() {" + (str "if(typeof process !== 'undefined' && process.argv) {" + (str (str "var result = " const-none ";") + "for(var idx = process.argv.length-1; idx >= 0; idx--) {" + (str "result = " (make-some "[process.argv[idx],result]") ";") + "}") + (str "return result;") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") }) (def LuxRT "LuxRT") -- cgit v1.2.3 From 69807626d51e2abf4c41a270d8e4de3ecec9e888 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Mar 2017 20:52:10 -0400 Subject: - The compiler can now load specialized modules, depending on the host-platform being targetted. --- luxc/src/lux/compiler/cache.clj | 4 +-- luxc/src/lux/compiler/io.clj | 40 ++++++++++++++------- luxc/src/lux/compiler/js.clj | 59 +++++++++++++++--------------- luxc/src/lux/compiler/jvm.clj | 79 ++++++++++++++++++++--------------------- 4 files changed, 97 insertions(+), 85 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj index 7299b7166..91aa8802b 100644 --- a/luxc/src/lux/compiler/cache.clj +++ b/luxc/src/lux/compiler/cache.clj @@ -123,7 +123,7 @@ (&/|map #(.split ^String % &&core/datum-separator 2) imports))] cache-table* (&/fold% (fn [cache-table* _import] (|do [:let [[_module _hash] _import] - file-content (&&io/read-file source-dirs (str _module ".lux")) + file-content (&&io/read-file source-dirs _module) output (pre-load! source-dirs cache-table* _module (hash file-content) load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] (return output))) @@ -199,7 +199,7 @@ (|do [:let [fs-cached-modules (enumerate-cached-modules!)] pre-loaded-modules (&/fold% (fn [cache-table module-name] (fn [_compiler] - (|case ((&&io/read-file source-dirs (str module-name ".lux")) + (|case ((&&io/read-file source-dirs module-name) _compiler) (&/$Left error) (return* _compiler cache-table) diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj index 82b80f624..f129fd3f0 100644 --- a/luxc/src/lux/compiler/io.clj +++ b/luxc/src/lux/compiler/io.clj @@ -10,17 +10,31 @@ (defn init-libs! [] (reset! !libs (&lib/load))) -(defn read-file [source-dirs ^String file-name] - (|case (&/|some (fn [^String source-dir] - (let [file (new java.io.File source-dir file-name)] - (if (.exists file) - (&/$Some file) - &/$None))) - source-dirs) - (&/$Some file) - (return (slurp file)) +(defn read-file [source-dirs module-name] + (|do [jvm? &/jvm? + js? &/js? + :let [^String host-file-name (cond jvm? (str module-name ".jvm.lux") + js? (str module-name ".js.lux") + :else (assert false "[I/O Error] Unknown host platform.")) + ^String lux-file-name (str module-name ".lux")]] + (|case (&/|some (fn [^String source-dir] + (let [host-file (new java.io.File source-dir host-file-name) + lux-file (new java.io.File source-dir lux-file-name)] + (cond (.exists host-file) + (&/$Some (&/T [host-file-name host-file])) - (&/$None) - (if-let [code (get @!libs file-name)] - (return code) - (&/fail-with-loc (str "[I/O Error] File doesn't exist: " file-name))))) + (.exists lux-file) + (&/$Some (&/T [lux-file-name lux-file])) + + :else + &/$None))) + source-dirs) + (&/$Some [file-name file]) + (return (&/T [file-name (slurp file)])) + + (&/$None) + (if-let [code (get @!libs host-file-name)] + (return (&/T [host-file-name code])) + (if-let [code (get @!libs lux-file-name)] + (return (&/T [lux-file-name code])) + (&/fail-with-loc (str "[I/O Error] Module doesn't exist: " module-name))))))) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index fa4bf9518..4f0546bf0 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -127,36 +127,35 @@ (&&/wrap-lux-obj state)]))))])) (defn compile-module [source-dirs name] - (let [file-name (str name ".lux")] - (|do [file-content (&&io/read-file source-dirs file-name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (&&cache/load name) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) - (|do [_ (&&cache/delete name) - _ (&&/init-buffer) - _ (&a-module/create-module name file-hash) - _ (&a-module/flag-active-module name) - _ (if (= "lux" name) - &&rt/compile-LuxRT - (return nil))] - (fn [state] - (|case ((&/exhaust% compiler-step) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [_ (&a-module/flag-compiled-module name) - _ &&/save-module-js! - module-descriptor (&&core/generate-module-descriptor file-hash) - _ (&&core/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message))))))))) - )) + (|do [[file-name file-content] (&&io/read-file source-dirs name) + :let [file-hash (hash file-content) + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] + (&/|eitherL (&&cache/load name) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc (str "[Compiler Error] Can't re-define a module: " name)) + (|do [_ (&&cache/delete name) + _ (&&/init-buffer) + _ (&a-module/create-module name file-hash) + _ (&a-module/flag-active-module name) + _ (if (= "lux" name) + &&rt/compile-LuxRT + (return nil))] + (fn [state] + (|case ((&/exhaust% compiler-step) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [_ (&a-module/flag-compiled-module name) + _ &&/save-module-js! + module-descriptor (&&core/generate-module-descriptor file-hash) + _ (&&core/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message))))))))) + ) (let [!err! *err*] (defn compile-program [mode program-module resources-dir source-dirs target-dir] diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 7fd764e56..6c4731e16 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -173,46 +173,45 @@ (let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) +datum-sig+ "Ljava/lang/Object;"] (defn compile-module [source-dirs name] - (let [file-name (str name ".lux")] - (|do [file-content (&&io/read-file source-dirs file-name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (&&cache/load name) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc "[Compiler Error] Can't re-define a module!") - (|do [_ (&&cache/delete name) - _ (&a-module/create-module name file-hash) - _ (&a-module/flag-active-module name) - :let [module-class-name (str (&host/->module-class name) "/_") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - module-class-name nil "java/lang/Object" nil) - (.visitSource file-name nil))] - _ (if (= "lux" name) - (|do [_ &&rt/compile-Function-class - _ &&rt/compile-LuxRT-class - _ &&rt/compile-LuxRunnable-class] - (return nil)) - (return nil))] - (fn [state] - (|case ((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [:let [_ (.visitEnd =class)] - _ (&a-module/flag-compiled-module name) - _ (&&/save-class! &/module-class-name (.toByteArray =class)) - module-descriptor (&&core/generate-module-descriptor file-hash) - _ (&&core/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message)))))))) - ) - ))) + (|do [[file-name file-content] (&&io/read-file source-dirs name) + :let [file-hash (hash file-content) + compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] + (&/|eitherL (&&cache/load name) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc "[Compiler Error] Can't re-define a module!") + (|do [_ (&&cache/delete name) + _ (&a-module/create-module name file-hash) + _ (&a-module/flag-active-module name) + :let [module-class-name (str (&host/->module-class name) "/_") + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + module-class-name nil "java/lang/Object" nil) + (.visitSource file-name nil))] + _ (if (= "lux" name) + (|do [_ &&rt/compile-Function-class + _ &&rt/compile-LuxRT-class + _ &&rt/compile-LuxRunnable-class] + (return nil)) + (return nil))] + (fn [state] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$source (&reader/from name file-content) state)) + (&/$Right ?state _) + (&/run-state (|do [:let [_ (.visitEnd =class)] + _ (&a-module/flag-compiled-module name) + _ (&&/save-class! &/module-class-name (.toByteArray =class)) + module-descriptor (&&core/generate-module-descriptor file-hash) + _ (&&core/write-module-descriptor! name module-descriptor)] + (return file-hash)) + ?state) + + (&/$Left ?message) + (&/fail* ?message)))))))) + ) + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) -- cgit v1.2.3 From 011547aae8e4664ecd63c8ebcefada7f8d9d940d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 13 Mar 2017 20:27:17 -0400 Subject: - Implemented missing degree functions. --- luxc/src/lux/compiler/js/rt.clj | 509 ++++++++-------------------------------- 1 file changed, 100 insertions(+), 409 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index c022dd3bb..c2b3cba01 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -14,412 +14,6 @@ [lux.analyser.base :as &a] [lux.compiler.js.base :as &&])) -;; (defn ^:private low-4b [^MethodVisitor =method] -;; (doto =method -;; ;; Assume there is a long at the top of the stack... -;; ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. -;; (.visitLdcInsn (int -1)) -;; (.visitInsn Opcodes/I2L) -;; ;; Then do a bitwise and. -;; (.visitInsn Opcodes/LAND) -;; )) - -;; (defn ^:private high-4b [^MethodVisitor =method] -;; (doto =method -;; ;; Assume there is a long at the top of the stack... -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LUSHR) -;; )) - -;; (defn ^:private swap2 [^MethodVisitor =method] -;; (doto =method -;; ;; X2, Y2 -;; (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 -;; (.visitInsn Opcodes/POP2) ;; Y2, X2 -;; )) - -;; (defn ^:private swap2x1 [^MethodVisitor =method] -;; (doto =method -;; ;; X1, Y2 -;; (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 -;; (.visitInsn Opcodes/POP2) ;; Y2, X1 -;; )) - -;; (defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class] -;; (|let [deg-bits 64 -;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil) -;; ;; Based on: http://stackoverflow.com/a/31629280/6823464 -;; (.visitCode) -;; ;; Bottom part -;; (.visitVarInsn Opcodes/LLOAD 0) low-4b -;; (.visitVarInsn Opcodes/LLOAD 2) low-4b -;; (.visitInsn Opcodes/LMUL) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LUSHR) -;; ;; Middle part -;; (.visitVarInsn Opcodes/LLOAD 0) high-4b -;; (.visitVarInsn Opcodes/LLOAD 2) low-4b -;; (.visitInsn Opcodes/LMUL) -;; (.visitVarInsn Opcodes/LLOAD 0) low-4b -;; (.visitVarInsn Opcodes/LLOAD 2) high-4b -;; (.visitInsn Opcodes/LMUL) -;; (.visitInsn Opcodes/LADD) -;; ;; Join middle and bottom -;; (.visitInsn Opcodes/LADD) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LUSHR) -;; ;; Top part -;; (.visitVarInsn Opcodes/LLOAD 0) high-4b -;; (.visitVarInsn Opcodes/LLOAD 2) high-4b -;; (.visitInsn Opcodes/LMUL) -;; ;; Join top with rest -;; (.visitInsn Opcodes/LADD) -;; ;; Return -;; (.visitInsn Opcodes/LRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)) -;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil) -;; (.visitCode) -;; ;; Based on: http://stackoverflow.com/a/8510587/6823464 -;; (.visitVarInsn Opcodes/LLOAD 0) -;; (.visitVarInsn Opcodes/LLOAD 2) high-4b -;; (.visitInsn Opcodes/LDIV) -;; (.visitLdcInsn (int 32)) -;; (.visitInsn Opcodes/LSHL) -;; (.visitInsn Opcodes/LRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)) -;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil) -;; (.visitCode) -;; ;; Translate high bytes -;; (.visitVarInsn Opcodes/LLOAD 0) high-4b -;; (.visitInsn Opcodes/L2D) -;; (.visitLdcInsn (double (Math/pow 2 32))) -;; (.visitInsn Opcodes/DDIV) -;; ;; Translate low bytes -;; (.visitVarInsn Opcodes/LLOAD 0) low-4b -;; (.visitInsn Opcodes/L2D) -;; (.visitLdcInsn (double (Math/pow 2 32))) -;; (.visitInsn Opcodes/DDIV) -;; (.visitLdcInsn (double (Math/pow 2 32))) -;; (.visitInsn Opcodes/DDIV) -;; ;; Combine and return -;; (.visitInsn Opcodes/DADD) -;; (.visitInsn Opcodes/DRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)) -;; _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil) -;; (.visitCode) -;; ;; Drop any excess -;; (.visitVarInsn Opcodes/DLOAD 0) -;; (.visitLdcInsn (double 1.0)) -;; (.visitInsn Opcodes/DREM) -;; ;; Shift upper half, but retain remaining decimals -;; (.visitLdcInsn (double (Math/pow 2 32))) -;; (.visitInsn Opcodes/DMUL) -;; ;; Make a copy, so the lower half can be extracted -;; (.visitInsn Opcodes/DUP2) -;; ;; Get that lower half -;; (.visitLdcInsn (double 1.0)) -;; (.visitInsn Opcodes/DREM) -;; (.visitLdcInsn (double (Math/pow 2 32))) -;; (.visitInsn Opcodes/DMUL) -;; ;; Turn it into a deg -;; (.visitInsn Opcodes/D2L) -;; ;; Turn the upper half into deg too -;; swap2 -;; (.visitInsn Opcodes/D2L) -;; ;; Combine both pieces -;; (.visitInsn Opcodes/LADD) -;; ;; FINISH -;; (.visitInsn Opcodes/LRETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label) -;; $not-set (new Label) -;; $next-iteration (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil) -;; (.visitCode) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index -;; (.visitLdcInsn (int deg-bits)) -;; (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) -;; (.visitVarInsn Opcodes/ASTORE 2) ;; digits -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 2) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/IADD) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B") -;; ;; Set digit -;; (.visitVarInsn Opcodes/ALOAD 2) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; swap2x1 -;; (.visitInsn Opcodes/BASTORE) -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 1) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label) -;; $is-less-than (new Label) -;; $is-equal (new Label)] -;; ;; [B0 <= [B1 -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil) -;; (.visitCode) -;; (.visitLdcInsn (int 0)) -;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int deg-bits)) -;; (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) -;; (.visitLdcInsn false) -;; (.visitInsn Opcodes/IRETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/BALOAD) ;; {D0} -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/BALOAD) ;; {D0, D1} -;; (.visitInsn Opcodes/DUP2) -;; (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than) -;; (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal) -;; ;; Is greater than... -;; (.visitLdcInsn false) -;; (.visitInsn Opcodes/IRETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $is-less-than) -;; (.visitInsn Opcodes/POP2) -;; (.visitLdcInsn true) -;; (.visitInsn Opcodes/IRETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $is-equal) -;; ;; Increment index -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/IADD) -;; (.visitVarInsn Opcodes/ISTORE 2) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label) -;; $simple-sub (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil) -;; (.visitCode) -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit} -;; (.visitInsn Opcodes/BALOAD) -;; (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit} -;; (.visitInsn Opcodes/DUP2) -;; (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;; Since $0 < $1 -;; (.visitInsn Opcodes/SWAP) -;; (.visitInsn Opcodes/ISUB) ;; $1 - $0 -;; (.visitLdcInsn (byte 10)) -;; (.visitInsn Opcodes/SWAP) -;; (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; swap2x1 -;; (.visitInsn Opcodes/BASTORE) -;; ;; Prepare to iterate... -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 2) -;; ;; Subtract 1 from next digit -;; (.visitLdcInsn (int 1)) -;; (.visitVarInsn Opcodes/ISTORE 1) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $simple-sub) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; swap2x1 -;; (.visitInsn Opcodes/BASTORE) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$loop-start (new Label) -;; $do-a-round (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil) -;; (.visitCode) -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitVarInsn Opcodes/ISTORE 2) ;; Index -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitJumpInsn Opcodes/IFGE $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits} -;; (.visitVarInsn Opcodes/ALOAD 1) -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit} -;; (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx} -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B") -;; (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits -;; ;; Decrement index -;; (.visitVarInsn Opcodes/ILOAD 2) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/ISUB) -;; (.visitVarInsn Opcodes/ISTORE 2) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; (.visitMaxs 0 0) -;; (.visitEnd))) -;; _ (let [$from (new Label) -;; $to (new Label) -;; $handler (new Label) -;; $loop-start (new Label) -;; $do-a-round (new Label) -;; $skip-power (new Label) -;; $iterate (new Label) -;; $bad-format (new Label)] -;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) -;; (.visitCode) -;; ;; Check prefix -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitLdcInsn ".") -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") -;; (.visitJumpInsn Opcodes/IFEQ $bad-format) -;; ;; Check if size is valid -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") -;; (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix . -;; (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format) -;; ;; Initialization -;; (.visitTryCatchBlock $from $to $handler "java/lang/Exception") -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitLdcInsn (int 1)) -;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") -;; (.visitLabel $from) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B") -;; (.visitLabel $to) -;; (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits... -;; (.visitLdcInsn (int 0)) -;; (.visitVarInsn Opcodes/ISTORE 1) ;; Index -;; (.visitLdcInsn (long 0)) -;; (.visitVarInsn Opcodes/LSTORE 2) ;; Output -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $loop-start) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int deg-bits)) -;; (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round) -;; (.visitVarInsn Opcodes/LLOAD 2) -;; &&/wrap-long -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $do-a-round) -;; (.visitVarInsn Opcodes/ALOAD 0) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B") -;; (.visitInsn Opcodes/DUP2) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z") -;; (.visitJumpInsn Opcodes/IFNE $skip-power) -;; ;; Subtract power -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B") -;; (.visitVarInsn Opcodes/ASTORE 0) -;; ;; Set bit on output -;; (.visitVarInsn Opcodes/LLOAD 2) -;; (.visitLdcInsn (long 1)) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int (dec deg-bits))) -;; (.visitInsn Opcodes/SWAP) -;; (.visitInsn Opcodes/ISUB) -;; (.visitInsn Opcodes/LSHL) -;; (.visitInsn Opcodes/LOR) -;; (.visitVarInsn Opcodes/LSTORE 2) -;; (.visitJumpInsn Opcodes/GOTO $iterate) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $skip-power) -;; (.visitInsn Opcodes/POP2) -;; ;; (.visitJumpInsn Opcodes/GOTO $iterate) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $iterate) -;; (.visitVarInsn Opcodes/ILOAD 1) -;; (.visitLdcInsn (int 1)) -;; (.visitInsn Opcodes/IADD) -;; (.visitVarInsn Opcodes/ISTORE 1) -;; ;; Iterate -;; (.visitJumpInsn Opcodes/GOTO $loop-start) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $handler) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; (.visitLabel $bad-format) -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") -;; (.visitInsn Opcodes/ARETURN) -;; (.visitMaxs 0 0) -;; (.visitEnd)))] -;; nil)) - (def ^:private const-none (str "[0,null," &&/unit "]")) (defn ^:private make-some [value] (str "[1,''," value "]")) @@ -619,7 +213,7 @@ "}" ;; Special case: L = MIN "else {" - "var halfL = LuxRT.shrI64(l,LuxRT.ONE);" + "var halfL = LuxRT.shrI64(l,1);" "var approx = LuxRT.shlI64(LuxRT.divI64(halfL,r),LuxRT.ONE);" (str "if((approx.H === 0) && (approx.L === 0)) {" (str "if(r.H < 0) {" @@ -724,6 +318,7 @@ "}") "})") "decodeI64" (str "(function decodeI64(input) {" + "input = LuxRT.clean_separators(input);" (str "if(/^-?\\d+$/.exec(input)) {" (str "var isNegative = (input.charAt(0) == '-');" "var sign = isNegative ? -1 : 1;" @@ -766,6 +361,7 @@ "}") "})") "decodeN64" (str "(function decodeN64(input) {" + "input = LuxRT.clean_separators(input);" (str "if(/^\\+\\d+$/.exec(input)) {" (str "input = input.substring(1);") (str "if(input.length <= 18) {" @@ -836,7 +432,37 @@ }) (def ^:private d64-methods - {"_add_deg_digit_powers" (str "(function _add_deg_digit_powers(left,right) {" + {"mulD64" (str "(function mulD64(l,r) {" + "var lL = LuxRT.fromNumberI64(l.L);" + "var rL = LuxRT.fromNumberI64(r.L);" + "var lH = LuxRT.fromNumberI64(l.H);" + "var rH = LuxRT.fromNumberI64(r.H);" + + "var bottom = LuxRT.ushrI64(LuxRT.mulI64(lL,rL),32);" + "var middle = LuxRT.addI64(LuxRT.mulI64(lH,rL),LuxRT.mulI64(lL,rH));" + "var top = LuxRT.mulI64(lH,rH);" + + "var bottomAndMiddle = LuxRT.ushrI64(LuxRT.addI64(middle,bottom),32);" + + "return LuxRT.addI64(top,bottomAndMiddle);" + "})") + "divD64" (str "(function divD64(l,r) {" + "return LuxRT.shlI64(LuxRT.divI64(l,LuxRT.fromNumberI64(r.H)),32);" + "})") + "degToReal" (str "(function degToReal(input) {" + "var two32 = Math.pow(2,32);" + "var high = input.H / two32;" + "var low = (input.L / two32) / two32;" + "return high+low;" + "})") + "realToDeg" (str "(function realToDeg(input) {" + "var two32 = Math.pow(2,32);" + "var shifted = (input % 1.0) * two32;" + "var low = ((shifted % 1.0) * two32) | 0;" + "var high = shifted | 0;" + "return LuxRT.makeI64(high,low);" + "})") + "_add_deg_digit_powers" (str "(function _add_deg_digit_powers(left,right) {" "var output = new Array(64);" "var carry = 0;" (str "for(var idx = 63; idx >= 0; idx--) {" @@ -886,6 +512,68 @@ "var raw = '.'.concat(digits.join(''));" "return raw.split(/0*$/)[0];" "})") + "deg_text_to_digits" (str "(function deg_text_to_digits(input) {" + "var output = new Array(64);" + (str "for(var idx = input.length-1; idx >= 0; idx--) {" + "output[idx] = parseInt(input.substring(idx, idx+1));" + "}") + "return output;" + "})") + "deg_digits_lt" (str "(function deg_digits_lt(l,r) {" + (str "for(var idx = 0; idx < 64; idx++) {" + (str "if(l[idx] < r[idx]) {" + "return true;" + "}" + "else if(l[idx] > r[idx]) {" + "return false;" + "}") + "}") + "return false;" + "})") + "deg_digits_sub_once" (str "(function deg_digits_sub_once(target,digit,idx) {" + (str "while(true) {" + (str "if(target[idx] > digit) {" + (str "target[idx] = target[idx] - digit;" + "return target;") + "}" + "else {" + (str "target[idx] = 10 - (digit - target[idx]);" + "idx--;" + "digit=1;") + "}") + "}") + "})") + "deg_digits_sub" (str "(function deg_digits_sub(l,r) {" + (str "for(var idx = 63; idx >= 0; idx--) {" + "l = LuxRT.deg_digits_sub_once(l,r[idx],idx);" + "}") + "return l;" + "})") + "decodeD64" (let [failure (str "return " const-none ";")] + (str "(function decodeD64(input) {" + "input = LuxRT.clean_separators(input);" + (str "if(/^\\.\\d+$/.exec(input) && input.length <= 65) {" + (str "try {" + (str "var digits = LuxRT.deg_text_to_digits(input.substring(1));") + "var output = LuxRT.makeI64(0,0);" + (str "for(var idx = 0; idx < 64; idx++) {" + "var power = LuxRT.deg_text_to_digits(idx);" + (str "if(LuxRT.deg_digits_lt(power,digits)) {" + (str "digits = LuxRT.deg_digits_sub(digits,power);" + "var powerBit = LuxRT.shlI64(LuxRT.makeI64(0,1),(63-idx));" + "output = LuxRT.orI64(output,powerBit);") + "}") + "}") + (str "return " (make-some "output") ";") + "}" + "catch(ex) {" + failure + "}") + "}" + "else {" + failure + "}") + "})")) }) (def ^:private io-methods @@ -1042,7 +730,10 @@ })) (def ^:private lux-methods - {"runTry" (str "(function runTry(op) {" + {"clean_separators" (str "(function clean_separators(input) {" + "return input.replace(/_/g,'');" + "})") + "runTry" (str "(function runTry(op) {" (str "try {" (str "return [1,'',op(null)];") "}" -- cgit v1.2.3 From 6f554dc5a4172cd2afd7bde30b5edcaf0266f63d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Mar 2017 00:04:09 -0400 Subject: - Implemented custom JS host procedures. --- luxc/src/lux/analyser.clj | 6 ++- luxc/src/lux/analyser/proc/js.clj | 93 +++++++++++++++++++++++++++++++++ luxc/src/lux/compiler/js.clj | 5 +- luxc/src/lux/compiler/js/proc/host.clj | 86 ++++++++++++++++++++++++++++++ luxc/src/lux/compiler/js/rt.clj | 17 +++++- luxc/src/lux/compiler/jvm/proc/host.clj | 1 - 6 files changed, 202 insertions(+), 6 deletions(-) create mode 100644 luxc/src/lux/analyser/proc/js.clj create mode 100644 luxc/src/lux/compiler/js/proc/host.clj (limited to 'luxc/src') diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 5f35d3c25..aaf441713 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -12,7 +12,8 @@ [module :as &&module] [parser :as &&a-parser]) (lux.analyser.proc [common :as &&common] - [jvm :as &&jvm]))) + [jvm :as &&jvm] + [js :as &&js]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -136,7 +137,8 @@ (case ?category "jvm" (|do [_ &/jvm-host] (&&jvm/analyse-host analyse exo-type compilers ?proc ?args)) - ;; "js" + "js" (|do [_ &/js-host] + (&&js/analyse-host analyse exo-type ?proc ?args)) ;; common (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) diff --git a/luxc/src/lux/analyser/proc/js.clj b/luxc/src/lux/analyser/proc/js.clj new file mode 100644 index 000000000..2d36dd0d9 --- /dev/null +++ b/luxc/src/lux/analyser/proc/js.clj @@ -0,0 +1,93 @@ +(ns lux.analyser.proc.js + (:require (clojure [template :refer [do-template]] + [string :as string]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return |case assert!]] + [type :as &type]) + (lux.analyser [base :as &&]))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (&&/analyse-1 analyse (&/$HostT "function" &/$Nil) ?function) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/$Cons =function =args) (&/|list))))))) + + ^:private analyse-js-new "new" + ^:private analyse-js-call "call" + ) + +(defn ^:private analyse-js-object-call [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =args (&/map% (partial &&/analyse-1+ analyse) ?args) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "object-call"]) (&/$Cons =object (&/$Cons =field =args)) (&/|list))))))) + +(defn ^:private analyse-js-ref [analyse exo-type ?values] + (|do [:let [(&/$Cons [_ (&/$TextS ?ref-name)] (&/$Nil)) ?values] + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "ref"]) (&/|list) (&/|list ?ref-name))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list =object =field) (&/|list))))))) + + ^:private analyse-js-get-field "get-field" + ^:private analyse-js-delete-field "delete-field" + ) + +(defn ^:private analyse-js-set-field [analyse exo-type ?values] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?value (&/$Nil)))) ?values] + =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object) + =field (&&/analyse-1 analyse &type/Text ?field) + =value (&&/analyse-1+ analyse ?value) + _ (&type/check exo-type (&/$HostT "object" &/$Nil)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" "set-field"]) (&/|list =object =field =value) (&/|list))))))) + +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + :let [output-type (&/$HostT &/$Nil)] + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["js" ]) (&/|list) (&/|list))))))) + + ^:private analyse-js-object "object" "object" + ^:private analyse-js-null "null" "object" + ^:private analyse-js-undefined "undefined" "undefined" + ) + +(defn analyse-host [analyse exo-type proc ?values] + (case proc + "new" (analyse-js-new analyse exo-type ?values) + "call" (analyse-js-call analyse exo-type ?values) + "object-call" (analyse-js-object-call analyse exo-type ?values) + "ref" (analyse-js-ref analyse exo-type ?values) + "object" (analyse-js-object analyse exo-type ?values) + "get-field" (analyse-js-get-field analyse exo-type ?values) + "set-field" (analyse-js-set-field analyse exo-type ?values) + "delete-field" (analyse-js-delete-field analyse exo-type ?values) + "null" (analyse-js-null analyse exo-type ?values) + "undefined" (analyse-js-undefined analyse exo-type ?values) + ;; else + (&/fail-with-loc (str "[Analyser Error] Unknown JS procedure: " proc))) + ) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 4f0546bf0..1537bb7de 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -23,7 +23,8 @@ [lux :as &&lux] [rt :as &&rt] [cache :as &&js-cache]) - (lux.compiler.js.proc [common :as &&common]) + (lux.compiler.js.proc [common :as &&common] + [host :as &&host]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -100,7 +101,7 @@ (&o/$proc [?proc-category ?proc-name] ?args special-args) (case ?proc-category - ;; "js" ... + "js" (&&host/compile-proc compile-expression ?proc-name ?args special-args) ;; common (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj new file mode 100644 index 000000000..3c0392a6b --- /dev/null +++ b/luxc/src/lux/compiler/js/proc/host.clj @@ -0,0 +1,86 @@ +(ns lux.compiler.js.proc.host + (:require (clojure [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return |let |case]]))) + +(defn ^:private compile-js-ref [compile ?values special-args] + (|do [:let [(&/$Cons ?name (&/$Nil)) special-args]] + (return ?name))) + +(defn ^:private compile-js-new [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "new (" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-call [compile ?values special-args] + (|do [:let [(&/$Cons ?function ?args) ?values] + =function (compile ?function) + =args (&/map% compile ?args)] + (return (str "(" =function ")(" + (->> =args + (&/|interpose ",") + (&/fold str "")) + ")")))) + +(defn ^:private compile-js-object-call [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] + =object (compile ?object) + =field (compile ?field) + =args (&/map% compile ?args)] + (return (str "LuxRT." "jsObjectCall" + "(" =object + "," =field + "," (str "[" (->> =args (&/|interpose ",") (&/fold str "")) "]") + ")")))) + +(defn ^:private compile-js-object [compile ?values special-args] + (|do [:let [(&/$Nil) ?values]] + (return "{}"))) + +(defn ^:private compile-js-get-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "(" =object ")" "[" =field "]")))) + +(defn ^:private compile-js-set-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?input (&/$Nil)))) ?values] + =object (compile ?object) + =field (compile ?field) + =input (compile ?input)] + (return (str "LuxRT." "jsSetField" "(" =object "," =field "," =input ")")))) + +(defn ^:private compile-js-delete-field [compile ?values special-args] + (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] + =object (compile ?object) + =field (compile ?field)] + (return (str "LuxRT." "jsDeleteField" "(" =object "," =field ")")))) + +(do-template [ ] + (defn [compile ?values special-args] + (return )) + + ^:private compile-js-null "null" + ^:private compile-js-undefined "undefined" + ) + +(defn compile-proc [compile proc-name ?values special-args] + (case proc-name + "new" (compile-js-new compile ?values special-args) + "call" (compile-js-call compile ?values special-args) + "object-call" (compile-js-object-call compile ?values special-args) + "ref" (compile-js-ref compile ?values special-args) + "object" (compile-js-object compile ?values special-args) + "get-field" (compile-js-get-field compile ?values special-args) + "set-field" (compile-js-set-field compile ?values special-args) + "delete-field" (compile-js-delete-field compile ?values special-args) + "null" (compile-js-null compile ?values special-args) + "undefined" (compile-js-undefined compile ?values special-args) + ;; else + (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["js" proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index c2b3cba01..cdd83883d 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -755,6 +755,20 @@ "})") }) +(def ^:private js-methods + {"jsSetField" (str "(function jsSetField(object, field, input) {" + "object[field] = input;" + "return object;" + "})") + "jsDeleteField" (str "(function jsDeleteField(object, field) {" + "delete object[field];" + "return object;" + "})") + "jsObjectCall" (str "(function jsObjectCall(object, method, args) {" + "return object[method].apply(object, args);" + "})") + }) + (def LuxRT "LuxRT") (def compile-LuxRT @@ -766,7 +780,8 @@ text-methods array-methods bit-methods - io-methods) + io-methods + js-methods) (map (fn [[key val]] (str key ":" val))) (interpose ",") diff --git a/luxc/src/lux/compiler/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj index 0e299f123..365a26937 100644 --- a/luxc/src/lux/compiler/jvm/proc/host.clj +++ b/luxc/src/lux/compiler/jvm/proc/host.clj @@ -1042,7 +1042,6 @@ (return nil))) (defn compile-proc [compile proc-name ?values special-args] - "jvm" (case proc-name "synchronized" (compile-jvm-synchronized compile ?values special-args) "load-class" (compile-jvm-load-class compile ?values special-args) -- cgit v1.2.3 From 50584a0acfb8272a4bc9a6e64ba964be141ebded Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Mar 2017 18:18:48 -0400 Subject: - Implemented Nat division, using a partial implementation of big integers. --- luxc/src/lux/compiler/js/rt.clj | 224 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 220 insertions(+), 4 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index cdd83883d..1b07ed531 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -195,7 +195,7 @@ "divI64" (str "(function divI64(l,r) {" (str "if((r.H === 0) && (r.L === 0)) {" ;; Special case: R = 0 - "throw Error('division by zero');" + "throw new Error('Cannot divide by zero!');" "}" "else if((l.H === 0) && (l.L === 0)) {" ;; Special case: L = 0 @@ -348,7 +348,223 @@ }) (def ^:private n64-methods - {"encodeN64" (str "(function encodeN64(input) {" + {"divWord" (str "(function divWord(result, n, d) {" + "var dLong = LuxRT.makeI64(0,d);" + (str "if (LuxRT.eqI64(dLong,LuxRT.ONE)) {" + (str "result[0] = n.L;" + "result[1] = 0;" + "return") + "}" + "else {" + ;; Approximate the quotient and remainder + (str "var q = LuxRT.divI64(LuxRT.ushrI64(n,1),LuxRT.ushrI64(dLong,1));" + "var r = LuxRT.subI64(n,LuxRT.mulI64(q,dLong));" + ;; Correct the approximation + (str "while(LuxRT.ltI64(r,LuxRT.ZERO)) {" + "r = LuxRT.addI64(r,dLong);" + "q = LuxRT.subI64(q,LuxRT.ONE);" + "}") + (str "while(LuxRT.ltI64(dLong,r) || LuxRT.eqI64(dLong,r)) {" + "r = LuxRT.subI64(r,dLong);" + "q = LuxRT.addI64(q,LuxRT.ONE);" + "}") + "result[0] = q.L;" + "result[1] = r.L;" + ) + "}") + "})") + "primitiveShiftLeftBigInt" (str "(function primitiveShiftLeftBigInt(input,shift) {" + "var output = input.slice();" + "var shift2 = 32 - shift;" + (str "for(var i = 0, c = output[i], m = (i + (input.length - 1)); i < m; i++) {" + "var b = c;" + "c = output[i+1];" + "output[i] = (b << shift) | (c >>> shift2);" + "}") + "output[(input.length - 1)] <<= shift;" + "return output;" + "})") + "primitiveShiftRightBigInt" (str "(function primitiveShiftRightBigInt(input,shift) {" + "var output = input.slice();" + "var shift2 = 32 - shift;" + (str "for(var i = (input.length - 1), c = output[i]; i > 0; i--) {" + "var b = c;" + "c = output[i-1];" + "output[i] = (c << shift2) | (b >>> shift);" + "}") + "output[0] >>>= shift;" + "return output;" + "})") + "shiftLeftBigInt" (str "(function shiftLeftBigInt(input,shift) {" + "var shiftInts = shift >>> 5;" + "var shiftBits = shift & 0x1F;" + "var bitsInHighWord = LuxRT.countI64(LuxRT.makeI64(input[0],0));" + (str "if(shift <= (32 - bitsInHighWord)) {" + "var shifted = LuxRT.shlI64(LuxRT.makeI64(input[0],input[1]),shiftBits);" + "return [shifted.H,shifted.L];" + "}") + "var inputLen = input[0] === 0 ? 1 : 2;" + "var newLen = inputLen + shiftInts + 1;" + (str "if(shiftBits <= (32 - bitsInHighWord)) {" + "newLen--;" + "}") + (str "if(input.length < newLen) {" + ;; The array must grow + "input = [0|0,input[0],input[1]];" + "}") + (str "if(nBits == 0) {" + "return input;" + "}") + (str "if(shiftBits <= (32 - bitsInHighWord)) {" + "return LuxRT.primitiveShiftLeftBigInt(input,shiftBits);" + "}" + "else {" + "return LuxRT.primitiveShiftRightBigInt(input,(32 - shiftBits));" + "}") + "})") + "shiftRightBigInt" (str "(function shiftRightBigInt(input,shift) {" + "var shiftInts = shift >>> 5;" + "var shiftBits = shift & 0x1F;" + "if(shiftBits === 0) { return input; }" + "var bitsInHighWord = LuxRT.countI64(LuxRT.makeI64(input[0],0));" + (str "if(shiftBits >= bitsInHighWord) {" + "return LuxRT.primitiveShiftLeftBigInt(input,(32-shiftBits));" + "}" + "else {" + "return LuxRT.primitiveShiftRightBigInt(input,shiftBits);" + "}") + "})") + "mulsubBigInt" (str "(function mulsubBigInt(q, a, x, len, offset) {" + "var xLong = LuxRT.makeI64(0,x);" + "var carry = LuxRT.ZERO;" + "offset += len;" + (str "for (var j = len-1; j >= 0; j--) {" + "var product = LuxRT.addI64(LuxRT.mulI64(LuxRT.makeI64(0,a[j]),xLong),carry);" + "var difference = LuxRT.subI64(LuxRT.makeI64(0,q[offset]),product);" + "carry = LuxRT.addI64(LuxRT.ushrI64(product,32),((difference.L > ~product.L) ? LuxRT.ONE : LuxRT.ZERO));" + "}") + "return carry.L;" + "})") + "divadd" (str "(function divadd(a, result, offset) {" + "var carry = LuxRT.ZERO;" + (str "for (var j = a.length - 1; j >= 0; j--) {" + "var sum = LuxRT.addI64(LuxRT.addI64(LuxRT.makeI64(0,a[j]),LuxRT.makeI64(0,result[j+offset])),carry);" + "result[j+offset] = sum.L;" + "carry = LuxRT.ushrI64(sum,32);" + "}") + "return carry.L;" + "})") + "normalizeBigInt" (str "(function normalizeBigInt(input) {" + (str "if(input[0] !== 0) {" + "return LuxRT.makeI64(input[0],input[1]);" + "}" + "else {" + (str "var numZeros = 0;" + (str "do {" + "numZeros++;" + "} while(numZeros < input.length && input[numZeros] == 0);") + "var tempInput = input.slice(input.length-Math.max(2,input.length-numZeros));" + "return LuxRT.makeI64(tempInput[0],tempInput[1]);") + "}") + "})") + "divmodBigInt" (str "(function divmodBigInt(subject,param) {" + (str "if(LuxRT.eqI64(param,LuxRT.ZERO)) {" + "throw new Error('Cannot divide by zero!');" + "}") + (str "if(LuxRT.eqI64(subject,LuxRT.ZERO)) {" + "return [LuxRT.ZERO, LuxRT.ZERO];" + "}") + (str "if(LuxRT.ltN64(subject,param)) {" + "return [LuxRT.ZERO, subject];" + "}") + (str "if(LuxRT.eqI64(subject,param)) {" + "return [LuxRT.ONE, LuxRT.ZERO];" + "}") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + "var divisor = param;" + "var remainder = subject.H === 0 ? [0|0,subject.L] : [0|0,subject.H,subject.L];" + "var paramLength = param.H === 0 ? 1 : 2;" + "var subjLength = subject.H === 0 ? 1 : 2;" + "var limit = subjLength - paramLength + 1;" + "var quotient = (limit === 1) ? [0|0] : [0|0,0|0];" + ;; Normalize the divisor + "var shift = 32 - LuxRT.countI64(LuxRT.makeI64(divisor.H,0));" + (str "if (shift > 0) {" + "divisor = LuxRT.shlI64(divisor,shift);" + "remainder = LuxRT.shiftLeftBigInt(remainder,shift);" + "}") + (str "if((remainder.length-1) === subjLength) {" + "remainder[0] = 0;" + "}") + "var dh = divisor.H;" + "var dhLong = LuxRT.makeI64(0,dh);" + "var dl = divisor.L;" + "var qWord = [0|0,0|0];" + ;; D2 Initialize j + (str "for(var j = 0; j < limit; j++) {" + ;; D3 Calculate qhat + ;; estimate qhat + "var qhat = 0;" + "var qrem = 0;" + "var skipCorrection = false;" + "var nh = remainder[j];" + "var nh2 = nh + 0x80000000;" + "var nm = remainder[j+1];" + (str "if(nh == dh) {" + (str "qhat = ~0;" + "qrem = nh + nm;" + "skipCorrection = (qrem + 0x80000000) < nh2;") + "}" + "else {" + (str "var nChunk = LuxRT.orI64(LuxRT.shlI64(LuxRT.fromNumberI64(nh),32),LuxRT.fromNumberI64(nm));") + (str "if(LuxRT.ltI64(LuxRT.ZERO,nChunk) || LuxRT.eqI64(LuxRT.ZERO,nChunk)) {" + (str "qhat = LuxRT.divI64(nChunk,dhLong).L;" + "qrem = LuxRT.subI64(nChunk,LuxRT.mulI64(qhat, dhLong)).L;") + "}" + "else {" + (str "LuxRT.divWord(qWord, nChunk, dh);" + "qhat = qWord[0];" + "qrem = qWord[1];" + ) + "}") + "if(qhat == 0) { continue; }" + (str "if(!skipCorrection) {" + ;; Correct qhat + (str "var qremLong = LuxRT.makeI64(0,qrem);" + "var dlLong = LuxRT.makeI64(0,dl);" + "var nl = LuxRT.makeI64(0,remainder[j+2]);" + "var rs = LuxRT.orI64(LuxRT.shlI64(qremLong,32),nl);" + "var estProduct = LuxRT.mulI64(dlLong,LuxRT.makeI64(0,qhat));" + (str "if(LuxRT.ltN64(rs,estProduct)) {" + (str "qhat--;" + "qrem = LuxRT.addI64(qremLong,dhLong).L;" + "qremLong = LuxRT.makeI64(0,qrem);" + (str "if(LuxRT.ltI64(dhLong,qremLong) || LuxRT.eqI64(dhLong,qremLong)) {" + (str "estProduct = LuxRT.mulI64(dlLong,LuxRT.makeI64(0,qhat));" + "rs = LuxRT.orI64(LuxRT.shlI64(qremLong,32),nl);" + "if(LuxRT.ltN64(rs,estProduct)) { qhat--; }") + "}")) + "}") + ) + "}") + ;; D4 Multiply and subtract + "remainder[j] = 0;" + "var borrow = LuxRT.mulsubBigInt(remainder, divisor, qhat, paramLength, j);" + ;; D5 Test remainder + (str "if (borrow + 0x80000000 > nh2) {" + ;; D6 Add back + "LuxRT.divadd(divisor, remainder, j+1);" + "qhat--;" + "}") + ;; Store the quotient digit + "quotient[j] = qhat;" + "}") + "}") ;; D7 loop on j + ;; D8 Unnormalize + "if(shift > 0) { remainder = LuxRT.shiftRightBigInt(remainder,shift); }" + "return [LuxRT.normalizeBigInt(quotient), LuxRT.normalizeBigInt(remainder)];" + "})") + "encodeN64" (str "(function encodeN64(input) {" (str "if(input.H < 0) {" ;; Too big "var lastDigit = LuxRT.remI64(input, LuxRT.makeI64(0,10));" @@ -406,7 +622,7 @@ "return LuxRT.ZERO;" "}" "else {" - "throw new Error('AWAITING BIG-INT DIVISION IMPLEMENTATION!!!');" + "return LuxRT.divmodBigInt(l,r)[0];" "}") "}") "}") @@ -417,7 +633,7 @@ "return l;" "}" "else {" - "throw new Error('AWAITING BIG-INT REMAINDER IMPLEMENTATION!!!');" + "return LuxRT.divmodBigInt(l,r)[1];" "}") "}" "else {" -- cgit v1.2.3 From 57d7b77d354338da57646f8b28eaccee4a7d2525 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Mar 2017 19:07:47 -0400 Subject: - Fixed a bug when hashing the module files when loading the cache. --- luxc/src/lux/compiler/cache.clj | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj index 91aa8802b..c51691322 100644 --- a/luxc/src/lux/compiler/cache.clj +++ b/luxc/src/lux/compiler/cache.clj @@ -123,7 +123,7 @@ (&/|map #(.split ^String % &&core/datum-separator 2) imports))] cache-table* (&/fold% (fn [cache-table* _import] (|do [:let [[_module _hash] _import] - file-content (&&io/read-file source-dirs _module) + [file-name file-content] (&&io/read-file source-dirs _module) output (pre-load! source-dirs cache-table* _module (hash file-content) load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] (return output))) @@ -204,7 +204,7 @@ (&/$Left error) (return* _compiler cache-table) - (&/$Right _compiler* file-content) + (&/$Right _compiler* [file-name file-content]) ((pre-load! source-dirs cache-table module-name (hash file-content) load-def-value install-all-defs-in-module uninstall-all-defs-in-module) _compiler*)))) -- cgit v1.2.3 From f215258b4b1a1847c05f0339af8807f8efd20f61 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Mar 2017 19:08:12 -0400 Subject: - Fixed a bug when compiling the ["io" "exit"] procedure on the JVM. --- luxc/src/lux/compiler/jvm/proc/common.clj | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index d434e0365..ffb621c3b 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -735,7 +735,8 @@ :let [_ (doto *writer* &&/unwrap-long (.visitInsn Opcodes/L2I) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V"))]] + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V") + (.visitInsn Opcodes/ACONST_NULL))]] (return nil))) (defn ^:private compile-io-current-time [compile ?values special-args] -- cgit v1.2.3 From ad2f9e165d2bdce646507f1aadd133b8f67ae75f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Mar 2017 19:15:12 -0400 Subject: - Can now select between JVM and JS compilation, based on command-line parameters. --- luxc/src/lux.clj | 8 ++++---- luxc/src/lux/compiler.clj | 17 +++++++++-------- 2 files changed, 13 insertions(+), 12 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj index 182ddf46f..2daf0000a 100644 --- a/luxc/src/lux.clj +++ b/luxc/src/lux.clj @@ -19,11 +19,11 @@ (defn -main [& args] (|case (&/->list args) - (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) - (time (&compiler/compile-program &/$Release program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir)) + (&/$Cons "release" (&/$Cons platform (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))) + (time (&compiler/compile-program platform &/$Release program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir)) - (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))) - (time (&compiler/compile-program &/$Debug program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir)) + (&/$Cons "debug" (&/$Cons platform (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))) + (time (&compiler/compile-program platform &/$Debug program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir)) (&/$Cons "repl" (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))) (&repl/repl (separate-paths resources-dirs) diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj index 0e78fa766..bffedb69e 100644 --- a/luxc/src/lux/compiler.clj +++ b/luxc/src/lux/compiler.clj @@ -10,13 +10,14 @@ [js :as &&js] ))) -(defn init! [resources-dirs ^String target-dir] +(defn init! [platform resources-dirs ^String target-dir] (do (reset! &&core/!output-dir target-dir) (&¶llel/setup!) (&&io/init-libs!) (.mkdirs (new java.io.File target-dir)) - (&&jvm/init! resources-dirs target-dir) - ;; (&&js/init! resources-dirs target-dir) + (case platform + "jvm" (&&jvm/init! resources-dirs target-dir) + "js" (&&js/init! resources-dirs target-dir)) )) (def all-compilers @@ -28,8 +29,8 @@ (defn compile-module [source-dirs name] (&&jvm/compile-module source-dirs name)) -(defn compile-program [mode program-module resources-dir source-dirs target-dir] - (init! resources-dir target-dir) - (&&jvm/compile-program mode program-module resources-dir source-dirs target-dir) - ;; (&&js/compile-program mode program-module resources-dir source-dirs target-dir) - ) +(defn compile-program [platform mode program-module resources-dir source-dirs target-dir] + (init! platform resources-dir target-dir) + (case platform + "jvm" (&&jvm/compile-program mode program-module resources-dir source-dirs target-dir) + "js" (&&js/compile-program mode program-module resources-dir source-dirs target-dir))) -- cgit v1.2.3 From 749608e2f4f9804f33812b194297201851343947 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 21 Mar 2017 23:22:21 -0400 Subject: - Now packaging the complete JS code. --- luxc/src/lux/compiler/js.clj | 14 +++++++++++--- luxc/src/lux/compiler/js/base.clj | 14 ++++++++++++-- 2 files changed, 23 insertions(+), 5 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 1537bb7de..be405ad33 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -131,7 +131,11 @@ (|do [[file-name file-content] (&&io/read-file source-dirs name) :let [file-hash (hash file-content) compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (&&cache/load name) + (&/|eitherL (|do [output (&&cache/load name) + ^StringBuilder total-buffer &&/get-total-buffer + :let [module-code-path (str @&&core/!output-dir java.io.File/separator name java.io.File/separator &&/module-js-name) + _ (.append total-buffer ^String (str (slurp module-code-path) "\n"))]] + (return output)) (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] (|do [module-exists? (&a-module/exists? name)] (if module-exists? @@ -166,8 +170,12 @@ &&js-cache/load-def-value &&js-cache/install-all-defs-in-module &&js-cache/uninstall-all-defs-in-module) - _ (compile-module source-dirs "lux")] - (compile-module source-dirs program-module))] + _ (compile-module source-dirs "lux") + _ (compile-module source-dirs program-module) + ^StringBuilder total-buffer &&/get-total-buffer + :let [full-program-file (str @&&core/!output-dir java.io.File/separator "program.js") + _ (&&core/write-file full-program-file (.getBytes (.toString total-buffer)))]] + (return nil))] (|case (m-action (&/init-state mode (&&/js-host))) (&/$Right ?state _) (do (println "Compilation complete!") diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index 417b35d5a..7f560b87d 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -21,13 +21,16 @@ (deftuple ["interpreter" - "buffer"]) + "buffer" + "total-buffer"]) (defn js-host [] (&/$Js (&/T [;; "interpreter" (.getScriptEngine (new NashornScriptEngineFactory)) ;; "buffer" &/$None + ;; "total-buffer" + (new StringBuilder) ]))) (def ^String module-js-name "module.js") @@ -44,6 +47,10 @@ (&/$None) (&/fail-with-loc "[Error] No buffer available.")))) +(def get-total-buffer + (|do [host &/js-host] + (return (&/get$ $total-buffer host)))) + (defn run-js! [^String js-code] (|do [host &/js-host :let [interpreter ^NashornScriptEngine (&/get$ $interpreter host)]] @@ -216,12 +223,15 @@ (|do [eval? &/get-eval module &/get-module-name ^StringBuilder buffer get-buffer + ^StringBuilder total-buffer get-total-buffer + :let [buffer-code (.toString buffer) + _ (.append total-buffer ^String (str buffer-code "\n"))] :let [_ (when (not eval?) (let [^String module* (&host/->module-class module) module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] (do (.mkdirs (File. module-dir)) (&&/write-file (str module-dir java.io.File/separator module-js-name) - (.getBytes (.toString buffer))))))]] + (.getBytes buffer-code)))))]] (return nil))) (defn js-module [module] -- cgit v1.2.3 From bc17742ca0cc3483353e2c76e25496c1b105d8ed Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 22 Mar 2017 18:54:07 -0400 Subject: - LuxRT functions/constants now live in the top-level namespace, instead of inside a LuxRT object. --- luxc/src/lux/compiler/js/lux.clj | 16 +- luxc/src/lux/compiler/js/proc/common.clj | 117 ++----- luxc/src/lux/compiler/js/proc/host.clj | 6 +- luxc/src/lux/compiler/js/rt.clj | 564 +++++++++++++++---------------- 4 files changed, 321 insertions(+), 382 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index ffb75a3ef..bf188803c 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -35,7 +35,7 @@ (defn [value] (let [high (-> value (bit-shift-right 32) int) low (-> value (bit-and mask-4b) (bit-shift-left 32) (bit-shift-right 32) int)] - (return (str &&rt/LuxRT "." "makeI64" "(" high "," low ")")))) + (return (str "LuxRT$makeI64" "(" high "," low ")")))) compile-nat compile-int @@ -134,7 +134,7 @@ (return (&/fold (fn [source step] (|let [[idx tail?] step method (if tail? "product_getRight" "product_getLeft")] - (str &&rt/LuxRT "." method "(" source "," idx ")"))) + (str "LuxRT$" method "(" source "," idx ")"))) (str "(" =value ")") _path)))) @@ -179,15 +179,15 @@ (&o/$NatPM _value) (|do [=value (compile-nat _value)] - (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$IntPM _value) (|do [=value (compile-int _value)] - (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$DegPM _value) (|do [=value (compile-deg _value)] - (return (str "if(!" (str "LuxRT.eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) + (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) (&o/$RealPM _value) (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) @@ -208,7 +208,7 @@ (&/$Right _idx) (&/T [_idx true])) getter (if is-tail? "product_getRight" "product_getLeft")] - (return (str (cursor-push (str &&rt/LuxRT "." getter "(" cursor-peek "," _idx ")"))))) + (return (str (cursor-push (str "LuxRT$" getter "(" cursor-peek "," _idx ")"))))) (&o/$VariantPM _idx+) (|let [[_idx is-last] (|case _idx+ @@ -217,7 +217,7 @@ (&/$Right _idx) (&/T [_idx true])) - temp-assignment (str "temp = " &&rt/LuxRT "." "sum_get(" cursor-peek "," _idx "," (if is-last "\"\"" "null") ");")] + temp-assignment (str "temp = LuxRT$sum_get(" cursor-peek "," _idx "," (if is-last "\"\"" "null") ");")] (return (str temp-assignment (str "if(temp !== null) {" (cursor-push "temp") @@ -382,7 +382,7 @@ (defn compile-program [compile ?body] (|do [=body (compile ?body) - :let [program-js (str (str "var " (register-name 0) " = LuxRT.programArgs();") + :let [program-js (str (str "var " (register-name 0) " = LuxRT$programArgs();") (str "(" =body ")(null);"))] eval? &/get-eval ^StringBuilder buffer &&/get-buffer diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index c7e741e01..907b6d512 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -19,7 +19,7 @@ (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] =input (compile ?input) =param (compile ?param)] - (return (str "LuxRT." "(" =input "," =param ")")))) + (return (str "LuxRT$" "(" =input "," =param ")")))) ^:private compile-bit-and "andI64" ^:private compile-bit-or "orI64" @@ -31,7 +31,7 @@ (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] =input (compile ?input) =param (compile ?param)] - (return (str "LuxRT." "(" =input "," =param ".L)")))) + (return (str "LuxRT$" "(" =input "," =param ".L)")))) ^:private compile-bit-shift-left "shlI64" ^:private compile-bit-shift-right "shrI64" @@ -41,7 +41,7 @@ (defn ^:private compile-bit-count [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] =input (compile ?input)] - (return (str "LuxRT.countI64(" =input ")")))) + (return (str "LuxRT$countI64(" =input ")")))) (defn ^:private compile-lux-is [compile ?values special-args] (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] @@ -52,12 +52,12 @@ (defn ^:private compile-lux-try [compile ?values special-args] (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] =op (compile ?op)] - (return (str "LuxRT.runTry(" =op ")")))) + (return (str "LuxRT$runTry(" =op ")")))) (defn ^:private compile-array-new [compile ?values special-args] (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] =length (compile ?length)] - (return (str "new Array(" (str "LuxRT.toNumberI64(" =length ")") ")")))) + (return (str "new Array(" (str "LuxRT$toNumberI64(" =length ")") ")")))) (defn ^:private compile-array-get [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values @@ -65,7 +65,7 @@ ] =array (compile ?array) =idx (compile ?idx)] - (return (str "LuxRT.arrayGet(" =array "," =idx ")")))) + (return (str "LuxRT$arrayGet(" =array "," =idx ")")))) (defn ^:private compile-array-put [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values @@ -74,7 +74,7 @@ =array (compile ?array) =idx (compile ?idx) =elem (compile ?elem)] - (return (str "LuxRT.arrayPut(" =array "," =idx "," =elem ")")))) + (return (str "LuxRT$arrayPut(" =array "," =idx "," =elem ")")))) (defn ^:private compile-array-remove [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values @@ -82,21 +82,21 @@ ] =array (compile ?array) =idx (compile ?idx)] - (return (str "LuxRT.arrayRemove(" =array "," =idx ")")))) + (return (str "LuxRT$arrayRemove(" =array "," =idx ")")))) (defn ^:private compile-array-size [compile ?values special-args] (|do [:let [(&/$Cons ?array (&/$Nil)) ?values ;; (&/$Nil) special-args ] =array (compile ?array)] - (return (str "LuxRT.fromNumberI64(" =array ".length" ")")))) + (return (str "LuxRT$fromNumberI64(" =array ".length" ")")))) (do-template [ ] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] =x (compile ?x) =y (compile ?y)] - (return (str &&rt/LuxRT "." "(" =x "," =y ")")))) + (return (str "LuxRT$" "(" =x "," =y ")")))) ^:private compile-nat-add "addI64" ^:private compile-nat-sub "subI64" @@ -144,7 +144,7 @@ (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str &&rt/LuxRT "." "(" =x ")")) + (return (str "LuxRT$" "(" =x ")")) )) ^:private compile-int-encode "encodeI64" @@ -161,7 +161,7 @@ (defn ^:private compile-real-hash [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str &&rt/LuxRT ".textHash(''+" =x ")")) + (return (str "LuxRT$textHash(''+" =x ")")) )) (do-template [ ] @@ -191,63 +191,6 @@ =x (compile ?x)] (return (str "(" =x ")" ".toString()")))) -;; (defn ^:private compile-nat-lt [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long) -;; $then (new Label) -;; $end (new Label) -;; _ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I") -;; (.visitLdcInsn (int -1)) -;; (.visitJumpInsn Opcodes/IF_ICMPEQ $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitJumpInsn Opcodes/GOTO $end) -;; (.visitLabel $then) -;; (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) -;; (.visitLabel $end))]] -;; (return nil))) - -;; (do-template [ ] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; _ (compile ?y) -;; :let [_ (doto *writer* -;; &&/unwrap-long)] -;; :let [_ (doto *writer* -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "(JJ)J") -;; &&/wrap-long)]] -;; (return nil))) - -;; ^:private compile-deg-mul "mul_deg" -;; ^:private compile-deg-div "div_deg" -;; ) - -;; (do-template [ ] -;; (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] -;; (defn [compile ?values special-args] -;; (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] -;; ^MethodVisitor *writer* &/get-writer -;; _ (compile ?x) -;; :let [_ (doto *writer* -;; -;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) -;; )]] -;; (return nil)))) - -;; ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double -;; ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long -;; ) - (do-template [] (defn [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] @@ -260,22 +203,22 @@ (defn ^:private compile-int-to-real [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str "LuxRT.toNumberI64(" =x ")")))) + (return (str "LuxRT$toNumberI64(" =x ")")))) (defn ^:private compile-real-to-int [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str "LuxRT.fromNumberI64(" =x ")")))) + (return (str "LuxRT$fromNumberI64(" =x ")")))) (defn ^:private compile-deg-to-real [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str "LuxRT.degToReal(" =x ")")))) + (return (str "LuxRT$degToReal(" =x ")")))) (defn ^:private compile-real-to-deg [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str "LuxRT.realToDeg(" =x ")")))) + (return (str "LuxRT$realToDeg(" =x ")")))) (do-template [ ] (defn [compile ?values special-args] @@ -311,7 +254,7 @@ =text (compile ?text) =part (compile ?part) =start (compile ?start)] - (return (str "LuxRT" "." "(" =text "," =part "," =start ")")))) + (return (str "LuxRT$" "(" =text "," =part "," =start ")")))) ^:private compile-text-last-index "lastIndex" ^:private compile-text-index "index" @@ -332,30 +275,30 @@ =text (compile ?text) =from (compile ?from) =to (compile ?to)] - (return (str "LuxRT.clip(" (str =text "," =from "," =to) ")")))) + (return (str "LuxRT$clip(" (str =text "," =from "," =to) ")")))) (defn ^:private compile-text-replace-all [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?to-find (&/$Cons ?replace-with (&/$Nil)))) ?values] =text (compile ?text) =to-find (compile ?to-find) =replace-with (compile ?replace-with)] - (return (str "LuxRT.replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) + (return (str "LuxRT$replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) (defn ^:private compile-text-size [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] =text (compile ?text)] - (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) + (return (str "LuxRT$fromNumberI64(" =text ".length" ")")))) (defn ^:private compile-text-hash [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] =text (compile ?text)] - (return (str "LuxRT.textHash(" =text ")")))) + (return (str "LuxRT$textHash(" =text ")")))) (defn ^:private compile-text-char [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] =text (compile ?text) =idx (compile ?idx)] - (return (str "LuxRT.textChar(" (str =text "," =idx) ")")))) + (return (str "LuxRT$textChar(" (str =text "," =idx) ")")))) (do-template [ ] (defn [compile ?values special-args] @@ -376,35 +319,35 @@ (defn ^:private compile-char-to-nat [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] - (return (str "LuxRT.fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) + (return (str "LuxRT$fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) (defn ^:private compile-nat-to-char [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] =x (compile ?x)] (return (str "{C:" (str "String.fromCharCode(" - (str "LuxRT.toNumberI64(" =x ")") + (str "LuxRT$toNumberI64(" =x ")") ")") "}")))) (defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] - (return (str "LuxRT.log(" =message ")")))) + (return (str "LuxRT$log(" =message ")")))) (defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] - (return (str "LuxRT.error(" =message ")")))) + (return (str "LuxRT$error(" =message ")")))) (defn ^:private compile-io-exit [compile ?values special-args] (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] =code (compile ?code)] - (return (str "(process && process.exit && process.exit(LuxRT.fromNumberI64(" =code ")))")))) + (return (str "(process && process.exit && process.exit(LuxRT$fromNumberI64(" =code ")))")))) (defn ^:private compile-io-current-time [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT.toNumberI64(" "(new Date()).getTime()" ")")))) + (return (str "LuxRT$toNumberI64(" "(new Date()).getTime()" ")")))) (defn ^:private compile-atom-new [compile ?values special-args] (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] @@ -434,7 +377,7 @@ (defn ^:private compile-process-concurrency-level [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT.fromNumberI64(1)")))) + (return (str "LuxRT$fromNumberI64(1)")))) (defn ^:private compile-process-future [compile ?values special-args] (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] @@ -450,7 +393,7 @@ (return (str "setTimeout(" (str "function() {" =procedure "(null)" "}") "," - (str "LuxRT.toNumberI64(" =milliseconds ")") + (str "LuxRT$toNumberI64(" =milliseconds ")") ")")))) (do-template [ ] diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj index 3c0392a6b..39bdb99c1 100644 --- a/luxc/src/lux/compiler/js/proc/host.clj +++ b/luxc/src/lux/compiler/js/proc/host.clj @@ -33,7 +33,7 @@ =object (compile ?object) =field (compile ?field) =args (&/map% compile ?args)] - (return (str "LuxRT." "jsObjectCall" + (return (str "LuxRT$" "jsObjectCall" "(" =object "," =field "," (str "[" (->> =args (&/|interpose ",") (&/fold str "")) "]") @@ -54,13 +54,13 @@ =object (compile ?object) =field (compile ?field) =input (compile ?input)] - (return (str "LuxRT." "jsSetField" "(" =object "," =field "," =input ")")))) + (return (str "LuxRT$" "jsSetField" "(" =object "," =field "," =input ")")))) (defn ^:private compile-js-delete-field [compile ?values special-args] (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] =object (compile ?object) =field (compile ?field)] - (return (str "LuxRT." "jsDeleteField" "(" =object "," =field ")")))) + (return (str "LuxRT$" "jsDeleteField" "(" =object "," =field ")")))) (do-template [ ] (defn [compile ?values special-args] diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 1b07ed531..a70a59689 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -19,7 +19,7 @@ (str "[1,''," value "]")) (def ^:private adt-methods - {"product_getLeft" (str "(function product_getLeft(product,index) {" + {"product_getLeft" (str "(function LuxRT$product_getLeft(product,index) {" "var index_min_length = (index+1);" "if(product.length > index_min_length) {" ;; No need for recursion @@ -27,10 +27,10 @@ "}" "else {" ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" + "return LuxRT$product_getLeft(product[product.length - 1], (index_min_length - product.length));" "}" "})") - "product_getRight" (str "(function product_getRight(product,index) {" + "product_getRight" (str "(function LuxRT$product_getRight(product,index) {" "var index_min_length = (index+1);" "if(product.length === index_min_length) {" ;; Last element. @@ -38,7 +38,7 @@ "}" "else if(product.length < index_min_length) {" ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "return LuxRT$product_getRight(product[product.length - 1], (index_min_length - product.length));" "}" "else {" ;; Must slice @@ -49,10 +49,10 @@ extact-match "return sum[2];" recursion-test (str (str "if(sum[1] === '') {" ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "return LuxRT$sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" "}" "else { " no-match " }"))] - (str "(function sum_get(sum,wantedTag,wantsLast) {" + (str "(function LuxRT$sum_get(sum,wantedTag,wantsLast) {" "if(wantedTag === sum[0]) {" (str "if(sum[1] === wantsLast) {" extact-match "}" "else {" recursion-test "}") @@ -67,51 +67,51 @@ "TWO_PWR_32" "((1 << 16) * (1 << 16))" "TWO_PWR_64" "(((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16)))" "TWO_PWR_63" "((((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16))) / 2)" - "getLowBitsUnsigned" (str "(function getLowBitsUnsigned(i64) {" - "return (i64.L >= 0) ? i64.L : (LuxRT.TWO_PWR_32 + i64.L);" + "getLowBitsUnsigned" (str "(function LuxRT$getLowBitsUnsigned(i64) {" + "return (i64.L >= 0) ? i64.L : (LuxRT$TWO_PWR_32 + i64.L);" "})") - "toNumberI64" (str "(function toNumberI64(i64) {" - "return (i64.H * LuxRT.TWO_PWR_32) + LuxRT.getLowBitsUnsigned(i64);" + "toNumberI64" (str "(function LuxRT$toNumberI64(i64) {" + "return (i64.H * LuxRT$TWO_PWR_32) + LuxRT$getLowBitsUnsigned(i64);" "})") - "fromNumberI64" (str "(function fromNumberI64(num) {" + "fromNumberI64" (str "(function LuxRT$fromNumberI64(num) {" (str "if (isNaN(num)) {" - "return LuxRT.ZERO;" + "return LuxRT$ZERO;" "}") - (str "else if (num <= -LuxRT.TWO_PWR_63) {" - "return LuxRT.MIN_VALUE_I64;" + (str "else if (num <= -LuxRT$TWO_PWR_63) {" + "return LuxRT$MIN_VALUE_I64;" "}") - (str "else if ((num + 1) >= LuxRT.TWO_PWR_63) {" - "return LuxRT.MAX_VALUE_I64;" + (str "else if ((num + 1) >= LuxRT$TWO_PWR_63) {" + "return LuxRT$MAX_VALUE_I64;" "}") (str "else if (num < 0) {" - "return LuxRT.negateI64(LuxRT.fromNumberI64(-num));" + "return LuxRT$negateI64(LuxRT$fromNumberI64(-num));" "}") (str "else {" - "return LuxRT.makeI64((num / LuxRT.TWO_PWR_32), (num % LuxRT.TWO_PWR_32));" + "return LuxRT$makeI64((num / LuxRT$TWO_PWR_32), (num % LuxRT$TWO_PWR_32));" "}") "})") - "makeI64" (str "(function makeI64(high,low) {" + "makeI64" (str "(function LuxRT$makeI64(high,low) {" "return { H: (high|0), L: (low|0)};" "})") "MIN_VALUE_I64" "{ H: (0x80000000|0), L: (0|0)}" "MAX_VALUE_I64" "{ H: (0x7FFFFFFF|0), L: (0xFFFFFFFF|0)}" "ONE" "{ H: (0|0), L: (1|0)}" "ZERO" "{ H: (0|0), L: (0|0)}" - "notI64" (str "(function notI64(i64) {" - "return LuxRT.makeI64(~i64.H,~i64.L);" + "notI64" (str "(function LuxRT$notI64(i64) {" + "return LuxRT$makeI64(~i64.H,~i64.L);" "})") - "negateI64" (str "(function negateI64(i64) {" - (str "if(LuxRT.eqI64(LuxRT.MIN_VALUE_I64,i64)) {" - "return LuxRT.MIN_VALUE_I64;" + "negateI64" (str "(function LuxRT$negateI64(i64) {" + (str "if(LuxRT$eqI64(LuxRT$MIN_VALUE_I64,i64)) {" + "return LuxRT$MIN_VALUE_I64;" "}") (str "else {" - "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.ONE);" + "return LuxRT$addI64(LuxRT$notI64(i64),LuxRT$ONE);" "}") "})") - "eqI64" (str "(function eqI64(l,r) {" + "eqI64" (str "(function LuxRT$eqI64(l,r) {" "return (l.H === r.H) && (l.L === r.L);" "})") - "addI64" (str "(function addI64(l,r) {" + "addI64" (str "(function LuxRT$addI64(l,r) {" "var l48 = l.H >>> 16;" "var l32 = l.H & 0xFFFF;" "var l16 = l.L >>> 16;" @@ -135,25 +135,25 @@ "x48 += l48 + r48;" "x48 &= 0xFFFF;" - "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "return LuxRT$makeI64((x48 << 16) | x32, (x16 << 16) | x00);" "})") - "subI64" (str "(function subI64(l,r) {" - "return LuxRT.addI64(l,LuxRT.negateI64(r));" + "subI64" (str "(function LuxRT$subI64(l,r) {" + "return LuxRT$addI64(l,LuxRT$negateI64(r));" "})") - "mulI64" (str "(function mulI64(l,r) {" + "mulI64" (str "(function LuxRT$mulI64(l,r) {" "if (l.H < 0) {" (str "if (r.H < 0) {" ;; Both are negative - "return mulI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" + "return LuxRT$mulI64(LuxRT$negateI64(l),LuxRT$negateI64(r));" "}" "else {" ;; Left is negative - "return LuxRT.negateI64(mulI64(LuxRT.negateI64(l),r));" + "return LuxRT$negateI64(LuxRT$mulI64(LuxRT$negateI64(l),r));" "}") "}" "else if (r.H < 0) {" ;; Right is negative - "return LuxRT.negateI64(mulI64(l,LuxRT.negateI64(r)));" + "return LuxRT$negateI64(LuxRT$mulI64(l,LuxRT$negateI64(r)));" "}" ;; Both are positive "else {" @@ -189,10 +189,10 @@ "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" "x48 &= 0xFFFF;" - "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "return LuxRT$makeI64((x48 << 16) | x32, (x16 << 16) | x00);" "}" "})") - "divI64" (str "(function divI64(l,r) {" + "divI64" (str "(function LuxRT$divI64(l,r) {" (str "if((r.H === 0) && (r.L === 0)) {" ;; Special case: R = 0 "throw new Error('Cannot divide by zero!');" @@ -201,109 +201,109 @@ ;; Special case: L = 0 "return l;" "}") - (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE_I64)) {" + (str "if(LuxRT$eqI64(l,LuxRT$MIN_VALUE_I64)) {" ;; Special case: L = MIN - (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {" + (str "if(LuxRT$eqI64(r,LuxRT$ONE) || LuxRT$eqI64(r,LuxRT$negateI64(LuxRT$ONE))) {" ;; Special case: L = MIN, R = 1|-1 - "return LuxRT.MIN_VALUE_I64;" + "return LuxRT$MIN_VALUE_I64;" "}" ;; Special case: L = R = MIN - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" - "return LuxRT.ONE;" + "else if(LuxRT$eqI64(r,LuxRT$MIN_VALUE_I64)) {" + "return LuxRT$ONE;" "}" ;; Special case: L = MIN "else {" - "var halfL = LuxRT.shrI64(l,1);" - "var approx = LuxRT.shlI64(LuxRT.divI64(halfL,r),LuxRT.ONE);" + "var halfL = LuxRT$shrI64(l,1);" + "var approx = LuxRT$shlI64(LuxRT$divI64(halfL,r),LuxRT$ONE);" (str "if((approx.H === 0) && (approx.L === 0)) {" (str "if(r.H < 0) {" - "return LuxRT.ONE;" + "return LuxRT$ONE;" "}" "else {" - "return LuxRT.negateI64(LuxRT.ONE);" + "return LuxRT$negateI64(LuxRT$ONE);" "}") "}" "else {" - "var rem = LuxRT.subI64(l,LuxRT.mulI64(r,approx));" - "return LuxRT.addI64(approx,LuxRT.divI64(rem,r));" + "var rem = LuxRT$subI64(l,LuxRT$mulI64(r,approx));" + "return LuxRT$addI64(approx,LuxRT$divI64(rem,r));" "}") "}") "}" - "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE_I64)) {" + "else if(LuxRT$eqI64(r,LuxRT$MIN_VALUE_I64)) {" ;; Special case: R = MIN - "return LuxRT.makeI64(0,0);" + "return LuxRT$makeI64(0,0);" "}") ;; Special case: negatives (str "if(l.H < 0) {" (str "if(r.H < 0) {" ;; Both are negative - "return LuxRT.divI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" + "return LuxRT$divI64(LuxRT$negateI64(l),LuxRT$negateI64(r));" "}" "else {" ;; Only L is negative - "return LuxRT.negateI64(LuxRT.divI64(LuxRT.negateI64(l),r));" + "return LuxRT$negateI64(LuxRT$divI64(LuxRT$negateI64(l),r));" "}") "}" "else if(r.H < 0) {" ;; R is negative - "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));" + "return LuxRT$negateI64(LuxRT$divI64(l,LuxRT$negateI64(r)));" "}") ;; Common case - (str "var res = LuxRT.ZERO;" + (str "var res = LuxRT$ZERO;" "var rem = l;" - (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {" - "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));" + (str "while(LuxRT$ltI64(r,rem) || LuxRT$eqI64(r,rem)) {" + "var approx = Math.max(1, Math.floor(LuxRT$toNumberI64(rem) / LuxRT$toNumberI64(r)));" "var log2 = Math.ceil(Math.log(approx) / Math.LN2);" "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);" - "var approxRes = LuxRT.fromNumberI64(approx);" - "var approxRem = LuxRT.mulI64(approxRes,r);" - (str "while((approxRem.H < 0) || LuxRT.ltI64(rem,approxRem)) {" + "var approxRes = LuxRT$fromNumberI64(approx);" + "var approxRem = LuxRT$mulI64(approxRes,r);" + (str "while((approxRem.H < 0) || LuxRT$ltI64(rem,approxRem)) {" "approx -= delta;" - "approxRes = LuxRT.fromNumberI64(approx);" - "approxRem = LuxRT.mulI64(approxRes,r);" + "approxRes = LuxRT$fromNumberI64(approx);" + "approxRem = LuxRT$mulI64(approxRes,r);" "}") (str "if((approxRes.H === 0) && (approxRes.L === 0)) {" - "approxRes = LuxRT.ONE;" + "approxRes = LuxRT$ONE;" "}") - "res = LuxRT.addI64(res,approxRes);" - "rem = LuxRT.subI64(rem,approxRem);" + "res = LuxRT$addI64(res,approxRes);" + "rem = LuxRT$subI64(rem,approxRem);" "}") "return res;") "})") - "remI64" (str "(function remI64(l,r) {" - "return LuxRT.subI64(l,LuxRT.mulI64(LuxRT.divI64(l,r),r));" + "remI64" (str "(function LuxRT$remI64(l,r) {" + "return LuxRT$subI64(l,LuxRT$mulI64(LuxRT$divI64(l,r),r));" "})") - "ltI64" (str "(function ltI64(l,r) {" + "ltI64" (str "(function LuxRT$ltI64(l,r) {" "var ln = l.H < 0;" "var rn = r.H < 0;" "if(ln && !rn) { return true; }" "if(!ln && rn) { return false; }" - "return (LuxRT.subI64(l,r).H < 0);" + "return (LuxRT$subI64(l,r).H < 0);" "})") - "encodeI64" (str "(function encodeI64(input) {" + "encodeI64" (str "(function LuxRT$encodeI64(input) {" ;; If input = 0 (str "if((input.H === 0) && (input.L === 0)) {" "return '0';" "}") ;; If input < 0 (str "if(input.H < 0) {" - (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE_I64)) {" - "var radix = LuxRT.makeI64(0,10);" - "var div = LuxRT.divI64(input,radix);" - "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);" - "return LuxRT.encodeI64(div).concat(rem.L+'');" + (str "if(LuxRT$eqI64(input,LuxRT$MIN_VALUE_I64)) {" + "var radix = LuxRT$makeI64(0,10);" + "var div = LuxRT$divI64(input,radix);" + "var rem = LuxRT$subI64(LuxRT$mulI64(div,radix),input);" + "return LuxRT$encodeI64(div).concat(rem.L+'');" "}") "}" (str "else {" - "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));" + "return '-'.concat(LuxRT$encodeI64(LuxRT$negateI64(input)));" "}")) ;; If input > 0 - (str "var chunker = LuxRT.makeI64(0,1000000);" + (str "var chunker = LuxRT$makeI64(0,1000000);" "var rem = input;" "var result = '';" "while (true) {" - (str "var remDiv = LuxRT.divI64(rem,chunker);" - "var chunk = LuxRT.subI64(rem,LuxRT.mulI64(remDiv,chunker));" + (str "var remDiv = LuxRT$divI64(rem,chunker);" + "var chunk = LuxRT$subI64(rem,LuxRT$mulI64(remDiv,chunker));" "var digits = (chunk.L >>> 0)+'';" "rem = remDiv;" (str "if((rem.H === 0) && (rem.L === 0)) {" @@ -317,27 +317,27 @@ "}")) "}") "})") - "decodeI64" (str "(function decodeI64(input) {" - "input = LuxRT.clean_separators(input);" + "decodeI64" (str "(function LuxRT$decodeI64(input) {" + "input = LuxRT$clean_separators(input);" (str "if(/^-?\\d+$/.exec(input)) {" (str "var isNegative = (input.charAt(0) == '-');" "var sign = isNegative ? -1 : 1;" "input = isNegative ? input.substring(1) : input;" - "var chunkPower = LuxRT.fromNumberI64(Math.pow(10, 8));" - "var result = LuxRT.ZERO;" + "var chunkPower = LuxRT$fromNumberI64(Math.pow(10, 8));" + "var result = LuxRT$ZERO;" (str "for (var i = 0; i < input.length; i += 8) {" "var size = Math.min(8, input.length - i);" "var value = parseInt(input.substring(i, i + size), 10);" (str "if (size < 8) {" - "var power = LuxRT.fromNumberI64(Math.pow(10, size));" - "result = LuxRT.addI64(LuxRT.mulI64(result,power),LuxRT.fromNumberI64(value));" + "var power = LuxRT$fromNumberI64(Math.pow(10, size));" + "result = LuxRT$addI64(LuxRT$mulI64(result,power),LuxRT$fromNumberI64(value));" "}" "else {" - "result = LuxRT.addI64(LuxRT.mulI64(result,chunkPower),LuxRT.fromNumberI64(value));" + "result = LuxRT$addI64(LuxRT$mulI64(result,chunkPower),LuxRT$fromNumberI64(value));" "}") "}") - "result = LuxRT.mulI64(result,LuxRT.fromNumberI64(sign));" + "result = LuxRT$mulI64(result,LuxRT$fromNumberI64(sign));" (str "return " (make-some "result") ";") ) "}" @@ -348,32 +348,32 @@ }) (def ^:private n64-methods - {"divWord" (str "(function divWord(result, n, d) {" - "var dLong = LuxRT.makeI64(0,d);" - (str "if (LuxRT.eqI64(dLong,LuxRT.ONE)) {" + {"divWord" (str "(function LuxRT$divWord(result, n, d) {" + "var dLong = LuxRT$makeI64(0,d);" + (str "if (LuxRT$eqI64(dLong,LuxRT$ONE)) {" (str "result[0] = n.L;" "result[1] = 0;" "return") "}" "else {" ;; Approximate the quotient and remainder - (str "var q = LuxRT.divI64(LuxRT.ushrI64(n,1),LuxRT.ushrI64(dLong,1));" - "var r = LuxRT.subI64(n,LuxRT.mulI64(q,dLong));" + (str "var q = LuxRT$divI64(LuxRT$ushrI64(n,1),LuxRT$ushrI64(dLong,1));" + "var r = LuxRT$subI64(n,LuxRT$mulI64(q,dLong));" ;; Correct the approximation - (str "while(LuxRT.ltI64(r,LuxRT.ZERO)) {" - "r = LuxRT.addI64(r,dLong);" - "q = LuxRT.subI64(q,LuxRT.ONE);" + (str "while(LuxRT$ltI64(r,LuxRT$ZERO)) {" + "r = LuxRT$addI64(r,dLong);" + "q = LuxRT$subI64(q,LuxRT$ONE);" "}") - (str "while(LuxRT.ltI64(dLong,r) || LuxRT.eqI64(dLong,r)) {" - "r = LuxRT.subI64(r,dLong);" - "q = LuxRT.addI64(q,LuxRT.ONE);" + (str "while(LuxRT$ltI64(dLong,r) || LuxRT$eqI64(dLong,r)) {" + "r = LuxRT$subI64(r,dLong);" + "q = LuxRT$addI64(q,LuxRT$ONE);" "}") "result[0] = q.L;" "result[1] = r.L;" ) "}") "})") - "primitiveShiftLeftBigInt" (str "(function primitiveShiftLeftBigInt(input,shift) {" + "primitiveShiftLeftBigInt" (str "(function LuxRT$primitiveShiftLeftBigInt(input,shift) {" "var output = input.slice();" "var shift2 = 32 - shift;" (str "for(var i = 0, c = output[i], m = (i + (input.length - 1)); i < m; i++) {" @@ -384,7 +384,7 @@ "output[(input.length - 1)] <<= shift;" "return output;" "})") - "primitiveShiftRightBigInt" (str "(function primitiveShiftRightBigInt(input,shift) {" + "primitiveShiftRightBigInt" (str "(function LuxRT$primitiveShiftRightBigInt(input,shift) {" "var output = input.slice();" "var shift2 = 32 - shift;" (str "for(var i = (input.length - 1), c = output[i]; i > 0; i--) {" @@ -395,12 +395,12 @@ "output[0] >>>= shift;" "return output;" "})") - "shiftLeftBigInt" (str "(function shiftLeftBigInt(input,shift) {" + "shiftLeftBigInt" (str "(function LuxRT$shiftLeftBigInt(input,shift) {" "var shiftInts = shift >>> 5;" "var shiftBits = shift & 0x1F;" - "var bitsInHighWord = LuxRT.countI64(LuxRT.makeI64(input[0],0));" + "var bitsInHighWord = LuxRT$countI64(LuxRT$makeI64(input[0],0));" (str "if(shift <= (32 - bitsInHighWord)) {" - "var shifted = LuxRT.shlI64(LuxRT.makeI64(input[0],input[1]),shiftBits);" + "var shifted = LuxRT$shlI64(LuxRT$makeI64(input[0],input[1]),shiftBits);" "return [shifted.H,shifted.L];" "}") "var inputLen = input[0] === 0 ? 1 : 2;" @@ -416,47 +416,47 @@ "return input;" "}") (str "if(shiftBits <= (32 - bitsInHighWord)) {" - "return LuxRT.primitiveShiftLeftBigInt(input,shiftBits);" + "return LuxRT$primitiveShiftLeftBigInt(input,shiftBits);" "}" "else {" - "return LuxRT.primitiveShiftRightBigInt(input,(32 - shiftBits));" + "return LuxRT$primitiveShiftRightBigInt(input,(32 - shiftBits));" "}") "})") - "shiftRightBigInt" (str "(function shiftRightBigInt(input,shift) {" + "shiftRightBigInt" (str "(function LuxRT$shiftRightBigInt(input,shift) {" "var shiftInts = shift >>> 5;" "var shiftBits = shift & 0x1F;" "if(shiftBits === 0) { return input; }" - "var bitsInHighWord = LuxRT.countI64(LuxRT.makeI64(input[0],0));" + "var bitsInHighWord = LuxRT$countI64(LuxRT$makeI64(input[0],0));" (str "if(shiftBits >= bitsInHighWord) {" - "return LuxRT.primitiveShiftLeftBigInt(input,(32-shiftBits));" + "return LuxRT$primitiveShiftLeftBigInt(input,(32-shiftBits));" "}" "else {" - "return LuxRT.primitiveShiftRightBigInt(input,shiftBits);" + "return LuxRT$primitiveShiftRightBigInt(input,shiftBits);" "}") "})") - "mulsubBigInt" (str "(function mulsubBigInt(q, a, x, len, offset) {" - "var xLong = LuxRT.makeI64(0,x);" - "var carry = LuxRT.ZERO;" + "mulsubBigInt" (str "(function LuxRT$mulsubBigInt(q, a, x, len, offset) {" + "var xLong = LuxRT$makeI64(0,x);" + "var carry = LuxRT$ZERO;" "offset += len;" (str "for (var j = len-1; j >= 0; j--) {" - "var product = LuxRT.addI64(LuxRT.mulI64(LuxRT.makeI64(0,a[j]),xLong),carry);" - "var difference = LuxRT.subI64(LuxRT.makeI64(0,q[offset]),product);" - "carry = LuxRT.addI64(LuxRT.ushrI64(product,32),((difference.L > ~product.L) ? LuxRT.ONE : LuxRT.ZERO));" + "var product = LuxRT$addI64(LuxRT$mulI64(LuxRT$makeI64(0,a[j]),xLong),carry);" + "var difference = LuxRT$subI64(LuxRT$makeI64(0,q[offset]),product);" + "carry = LuxRT$addI64(LuxRT$ushrI64(product,32),((difference.L > ~product.L) ? LuxRT$ONE : LuxRT$ZERO));" "}") "return carry.L;" "})") - "divadd" (str "(function divadd(a, result, offset) {" - "var carry = LuxRT.ZERO;" + "divadd" (str "(function LuxRT$divadd(a, result, offset) {" + "var carry = LuxRT$ZERO;" (str "for (var j = a.length - 1; j >= 0; j--) {" - "var sum = LuxRT.addI64(LuxRT.addI64(LuxRT.makeI64(0,a[j]),LuxRT.makeI64(0,result[j+offset])),carry);" + "var sum = LuxRT$addI64(LuxRT$addI64(LuxRT$makeI64(0,a[j]),LuxRT$makeI64(0,result[j+offset])),carry);" "result[j+offset] = sum.L;" - "carry = LuxRT.ushrI64(sum,32);" + "carry = LuxRT$ushrI64(sum,32);" "}") "return carry.L;" "})") - "normalizeBigInt" (str "(function normalizeBigInt(input) {" + "normalizeBigInt" (str "(function LuxRT$normalizeBigInt(input) {" (str "if(input[0] !== 0) {" - "return LuxRT.makeI64(input[0],input[1]);" + "return LuxRT$makeI64(input[0],input[1]);" "}" "else {" (str "var numZeros = 0;" @@ -464,21 +464,21 @@ "numZeros++;" "} while(numZeros < input.length && input[numZeros] == 0);") "var tempInput = input.slice(input.length-Math.max(2,input.length-numZeros));" - "return LuxRT.makeI64(tempInput[0],tempInput[1]);") + "return LuxRT$makeI64(tempInput[0],tempInput[1]);") "}") "})") - "divmodBigInt" (str "(function divmodBigInt(subject,param) {" - (str "if(LuxRT.eqI64(param,LuxRT.ZERO)) {" + "divmodBigInt" (str "(function LuxRT$divmodBigInt(subject,param) {" + (str "if(LuxRT$eqI64(param,LuxRT$ZERO)) {" "throw new Error('Cannot divide by zero!');" "}") - (str "if(LuxRT.eqI64(subject,LuxRT.ZERO)) {" - "return [LuxRT.ZERO, LuxRT.ZERO];" + (str "if(LuxRT$eqI64(subject,LuxRT$ZERO)) {" + "return [LuxRT$ZERO, LuxRT$ZERO];" "}") - (str "if(LuxRT.ltN64(subject,param)) {" - "return [LuxRT.ZERO, subject];" + (str "if(LuxRT$ltN64(subject,param)) {" + "return [LuxRT$ZERO, subject];" "}") - (str "if(LuxRT.eqI64(subject,param)) {" - "return [LuxRT.ONE, LuxRT.ZERO];" + (str "if(LuxRT$eqI64(subject,param)) {" + "return [LuxRT$ONE, LuxRT$ZERO];" "}") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; "var divisor = param;" @@ -488,16 +488,16 @@ "var limit = subjLength - paramLength + 1;" "var quotient = (limit === 1) ? [0|0] : [0|0,0|0];" ;; Normalize the divisor - "var shift = 32 - LuxRT.countI64(LuxRT.makeI64(divisor.H,0));" + "var shift = 32 - LuxRT$countI64(LuxRT$makeI64(divisor.H,0));" (str "if (shift > 0) {" - "divisor = LuxRT.shlI64(divisor,shift);" - "remainder = LuxRT.shiftLeftBigInt(remainder,shift);" + "divisor = LuxRT$shlI64(divisor,shift);" + "remainder = LuxRT$shiftLeftBigInt(remainder,shift);" "}") (str "if((remainder.length-1) === subjLength) {" "remainder[0] = 0;" "}") "var dh = divisor.H;" - "var dhLong = LuxRT.makeI64(0,dh);" + "var dhLong = LuxRT$makeI64(0,dh);" "var dl = divisor.L;" "var qWord = [0|0,0|0];" ;; D2 Initialize j @@ -516,13 +516,13 @@ "skipCorrection = (qrem + 0x80000000) < nh2;") "}" "else {" - (str "var nChunk = LuxRT.orI64(LuxRT.shlI64(LuxRT.fromNumberI64(nh),32),LuxRT.fromNumberI64(nm));") - (str "if(LuxRT.ltI64(LuxRT.ZERO,nChunk) || LuxRT.eqI64(LuxRT.ZERO,nChunk)) {" - (str "qhat = LuxRT.divI64(nChunk,dhLong).L;" - "qrem = LuxRT.subI64(nChunk,LuxRT.mulI64(qhat, dhLong)).L;") + (str "var nChunk = LuxRT$orI64(LuxRT$shlI64(LuxRT$fromNumberI64(nh),32),LuxRT$fromNumberI64(nm));") + (str "if(LuxRT$ltI64(LuxRT$ZERO,nChunk) || LuxRT$eqI64(LuxRT$ZERO,nChunk)) {" + (str "qhat = LuxRT$divI64(nChunk,dhLong).L;" + "qrem = LuxRT$subI64(nChunk,LuxRT$mulI64(qhat, dhLong)).L;") "}" "else {" - (str "LuxRT.divWord(qWord, nChunk, dh);" + (str "LuxRT$divWord(qWord, nChunk, dh);" "qhat = qWord[0];" "qrem = qWord[1];" ) @@ -530,30 +530,30 @@ "if(qhat == 0) { continue; }" (str "if(!skipCorrection) {" ;; Correct qhat - (str "var qremLong = LuxRT.makeI64(0,qrem);" - "var dlLong = LuxRT.makeI64(0,dl);" - "var nl = LuxRT.makeI64(0,remainder[j+2]);" - "var rs = LuxRT.orI64(LuxRT.shlI64(qremLong,32),nl);" - "var estProduct = LuxRT.mulI64(dlLong,LuxRT.makeI64(0,qhat));" - (str "if(LuxRT.ltN64(rs,estProduct)) {" + (str "var qremLong = LuxRT$makeI64(0,qrem);" + "var dlLong = LuxRT$makeI64(0,dl);" + "var nl = LuxRT$makeI64(0,remainder[j+2]);" + "var rs = LuxRT$orI64(LuxRT$shlI64(qremLong,32),nl);" + "var estProduct = LuxRT$mulI64(dlLong,LuxRT$makeI64(0,qhat));" + (str "if(LuxRT$ltN64(rs,estProduct)) {" (str "qhat--;" - "qrem = LuxRT.addI64(qremLong,dhLong).L;" - "qremLong = LuxRT.makeI64(0,qrem);" - (str "if(LuxRT.ltI64(dhLong,qremLong) || LuxRT.eqI64(dhLong,qremLong)) {" - (str "estProduct = LuxRT.mulI64(dlLong,LuxRT.makeI64(0,qhat));" - "rs = LuxRT.orI64(LuxRT.shlI64(qremLong,32),nl);" - "if(LuxRT.ltN64(rs,estProduct)) { qhat--; }") + "qrem = LuxRT$addI64(qremLong,dhLong).L;" + "qremLong = LuxRT$makeI64(0,qrem);" + (str "if(LuxRT$ltI64(dhLong,qremLong) || LuxRT$eqI64(dhLong,qremLong)) {" + (str "estProduct = LuxRT$mulI64(dlLong,LuxRT$makeI64(0,qhat));" + "rs = LuxRT$orI64(LuxRT$shlI64(qremLong,32),nl);" + "if(LuxRT$ltN64(rs,estProduct)) { qhat--; }") "}")) "}") ) "}") ;; D4 Multiply and subtract "remainder[j] = 0;" - "var borrow = LuxRT.mulsubBigInt(remainder, divisor, qhat, paramLength, j);" + "var borrow = LuxRT$mulsubBigInt(remainder, divisor, qhat, paramLength, j);" ;; D5 Test remainder (str "if (borrow + 0x80000000 > nh2) {" ;; D6 Add back - "LuxRT.divadd(divisor, remainder, j+1);" + "LuxRT$divadd(divisor, remainder, j+1);" "qhat--;" "}") ;; Store the quotient digit @@ -561,35 +561,35 @@ "}") "}") ;; D7 loop on j ;; D8 Unnormalize - "if(shift > 0) { remainder = LuxRT.shiftRightBigInt(remainder,shift); }" - "return [LuxRT.normalizeBigInt(quotient), LuxRT.normalizeBigInt(remainder)];" + "if(shift > 0) { remainder = LuxRT$shiftRightBigInt(remainder,shift); }" + "return [LuxRT$normalizeBigInt(quotient), LuxRT$normalizeBigInt(remainder)];" "})") - "encodeN64" (str "(function encodeN64(input) {" + "encodeN64" (str "(function LuxRT$encodeN64(input) {" (str "if(input.H < 0) {" ;; Too big - "var lastDigit = LuxRT.remI64(input, LuxRT.makeI64(0,10));" - "var minusLastDigit = LuxRT.divI64(input, LuxRT.makeI64(0,10));" - "return '+'.concat(LuxRT.encodeI64(minusLastDigit)).concat(LuxRT.encodeI64(lastDigit));" + "var lastDigit = LuxRT$remI64(input, LuxRT$makeI64(0,10));" + "var minusLastDigit = LuxRT$divI64(input, LuxRT$makeI64(0,10));" + "return '+'.concat(LuxRT$encodeI64(minusLastDigit)).concat(LuxRT$encodeI64(lastDigit));" "}" "else {" ;; Small enough - "return '+'.concat(LuxRT.encodeI64(input));" + "return '+'.concat(LuxRT$encodeI64(input));" "}") "})") - "decodeN64" (str "(function decodeN64(input) {" - "input = LuxRT.clean_separators(input);" + "decodeN64" (str "(function LuxRT$decodeN64(input) {" + "input = LuxRT$clean_separators(input);" (str "if(/^\\+\\d+$/.exec(input)) {" (str "input = input.substring(1);") (str "if(input.length <= 18) {" ;; Short enough... - "return LuxRT.decodeI64(input);" + "return LuxRT$decodeI64(input);" "}" "else {" ;; Too long - (str "var prefix = LuxRT.decodeI64(input.substring(0, input.length-1))[2];" - "var suffix = LuxRT.decodeI64(input.charAt(input.length-1))[2];" - "var total = LuxRT.addI64(LuxRT.mulI64(prefix,LuxRT.fromNumberI64(10)),suffix);" - (str "if(LuxRT.ltN64(total,prefix)) {" + (str "var prefix = LuxRT$decodeI64(input.substring(0, input.length-1))[2];" + "var suffix = LuxRT$decodeI64(input.charAt(input.length-1))[2];" + "var total = LuxRT$addI64(LuxRT$mulI64(prefix,LuxRT$fromNumberI64(10)),suffix);" + (str "if(LuxRT$ltN64(total,prefix)) {" (str "return " const-none ";") "}" "else {" @@ -601,84 +601,84 @@ (str "return " const-none ";") "}") "})") - "divN64" (str "(function divN64(l,r) {" - (str "if(LuxRT.ltI64(r,LuxRT.ZERO)) {" - (str "if(LuxRT.ltN64(l,r)) {" - "return LuxRT.ZERO;" + "divN64" (str "(function LuxRT$divN64(l,r) {" + (str "if(LuxRT$ltI64(r,LuxRT$ZERO)) {" + (str "if(LuxRT$ltN64(l,r)) {" + "return LuxRT$ZERO;" "}" "else {" - "return LuxRT.ONE;" + "return LuxRT$ONE;" "}") "}" - "else if(LuxRT.ltI64(LuxRT.ZERO,l)) {" - "return LuxRT.divI64(l,r);" + "else if(LuxRT$ltI64(LuxRT$ZERO,l)) {" + "return LuxRT$divI64(l,r);" "}" "else {" - (str "if(LuxRT.eqI64(LuxRT.ZERO,r)) {" + (str "if(LuxRT$eqI64(LuxRT$ZERO,r)) {" "throw new Error('Cannot divide by zero!');" "}" "else {" - (str "if(LuxRT.ltI64(l,r)) {" - "return LuxRT.ZERO;" + (str "if(LuxRT$ltI64(l,r)) {" + "return LuxRT$ZERO;" "}" "else {" - "return LuxRT.divmodBigInt(l,r)[0];" + "return LuxRT$divmodBigInt(l,r)[0];" "}") "}") "}") "})") - "remN64" (str "(function remN64(l,r) {" - (str "if(LuxRT.ltI64(l,LuxRT.ZERO) || LuxRT.ltI64(r,LuxRT.ZERO)) {" - (str "if(LuxRT.ltN64(l,r)) {" + "remN64" (str "(function LuxRT$remN64(l,r) {" + (str "if(LuxRT$ltI64(l,LuxRT$ZERO) || LuxRT$ltI64(r,LuxRT$ZERO)) {" + (str "if(LuxRT$ltN64(l,r)) {" "return l;" "}" "else {" - "return LuxRT.divmodBigInt(l,r)[1];" + "return LuxRT$divmodBigInt(l,r)[1];" "}") "}" "else {" - "return LuxRT.remI64(l,r);" + "return LuxRT$remI64(l,r);" "}") "})") - "ltN64" (str "(function ltN64(l,r) {" - "var li = LuxRT.addI64(l,LuxRT.MIN_VALUE_I64);" - "var ri = LuxRT.addI64(r,LuxRT.MIN_VALUE_I64);" - "return LuxRT.ltI64(li,ri);" + "ltN64" (str "(function LuxRT$ltN64(l,r) {" + "var li = LuxRT$addI64(l,LuxRT$MIN_VALUE_I64);" + "var ri = LuxRT$addI64(r,LuxRT$MIN_VALUE_I64);" + "return LuxRT$ltI64(li,ri);" "})") }) (def ^:private d64-methods - {"mulD64" (str "(function mulD64(l,r) {" - "var lL = LuxRT.fromNumberI64(l.L);" - "var rL = LuxRT.fromNumberI64(r.L);" - "var lH = LuxRT.fromNumberI64(l.H);" - "var rH = LuxRT.fromNumberI64(r.H);" + {"mulD64" (str "(function LuxRT$mulD64(l,r) {" + "var lL = LuxRT$fromNumberI64(l.L);" + "var rL = LuxRT$fromNumberI64(r.L);" + "var lH = LuxRT$fromNumberI64(l.H);" + "var rH = LuxRT$fromNumberI64(r.H);" - "var bottom = LuxRT.ushrI64(LuxRT.mulI64(lL,rL),32);" - "var middle = LuxRT.addI64(LuxRT.mulI64(lH,rL),LuxRT.mulI64(lL,rH));" - "var top = LuxRT.mulI64(lH,rH);" + "var bottom = LuxRT$ushrI64(LuxRT$mulI64(lL,rL),32);" + "var middle = LuxRT$addI64(LuxRT$mulI64(lH,rL),LuxRT$mulI64(lL,rH));" + "var top = LuxRT$mulI64(lH,rH);" - "var bottomAndMiddle = LuxRT.ushrI64(LuxRT.addI64(middle,bottom),32);" + "var bottomAndMiddle = LuxRT$ushrI64(LuxRT$addI64(middle,bottom),32);" - "return LuxRT.addI64(top,bottomAndMiddle);" + "return LuxRT$addI64(top,bottomAndMiddle);" "})") - "divD64" (str "(function divD64(l,r) {" - "return LuxRT.shlI64(LuxRT.divI64(l,LuxRT.fromNumberI64(r.H)),32);" + "divD64" (str "(function LuxRT$divD64(l,r) {" + "return LuxRT$shlI64(LuxRT$divI64(l,LuxRT$fromNumberI64(r.H)),32);" "})") - "degToReal" (str "(function degToReal(input) {" + "degToReal" (str "(function LuxRT$degToReal(input) {" "var two32 = Math.pow(2,32);" "var high = input.H / two32;" "var low = (input.L / two32) / two32;" "return high+low;" "})") - "realToDeg" (str "(function realToDeg(input) {" + "realToDeg" (str "(function LuxRT$realToDeg(input) {" "var two32 = Math.pow(2,32);" "var shifted = (input % 1.0) * two32;" "var low = ((shifted % 1.0) * two32) | 0;" "var high = shifted | 0;" - "return LuxRT.makeI64(high,low);" + "return LuxRT$makeI64(high,low);" "})") - "_add_deg_digit_powers" (str "(function _add_deg_digit_powers(left,right) {" + "_add_deg_digit_powers" (str "(function LuxRT$_add_deg_digit_powers(left,right) {" "var output = new Array(64);" "var carry = 0;" (str "for(var idx = 63; idx >= 0; idx--) {" @@ -688,7 +688,7 @@ "}") "return output;" "})") - "_times5" (str "(function _times5(exp,digits) {" + "_times5" (str "(function LuxRT$_times5(exp,digits) {" "var carry = 0;" (str "for(var idx = exp; idx >= 0; idx--) {" "var raw = (digits[exp] * 5) + carry;" @@ -697,15 +697,15 @@ "}") "return digits;" "})") - "_deg_digit_power" (str "(function _deg_digit_power(exp) {" + "_deg_digit_power" (str "(function LuxRT$_deg_digit_power(exp) {" "var digits = new Array(64);" "digits[exp] = 1;" (str "for(var idx = exp; idx >= 0; idx--) {" - "digits = LuxRT._times5(exp,digits);" + "digits = LuxRT$_times5(exp,digits);" "}") "return digits;" "})") - "_bitIsSet" (str "(function _bitIsSet(input,idx) {" + "_bitIsSet" (str "(function LuxRT$_bitIsSet(input,idx) {" "idx &= 63;" (str "if(idx < 32) {" "return (input.L & (1 << idx)) !== 0;" @@ -714,28 +714,28 @@ "return (input.H & (1 << (idx - 32))) !== 0;" "}") "})") - "encodeD64" (str "(function encodeD64(input) {" - (str "if(LuxRT.eqI64(input,LuxRT.ZERO)) {" + "encodeD64" (str "(function LuxRT$encodeD64(input) {" + (str "if(LuxRT$eqI64(input,LuxRT$ZERO)) {" "return '.0';" "}") "var digits = new Array(64);" (str "for(var idx = 63; idx >= 0; idx--) {" - (str "if(LuxRT._bitIsSet(input,idx)) {" - "var power = LuxRT._deg_digit_power(63 - idx);" - "digits = LuxRT._add_deg_digit_powers(digits,power);" + (str "if(LuxRT$_bitIsSet(input,idx)) {" + "var power = LuxRT$_deg_digit_power(63 - idx);" + "digits = LuxRT$_add_deg_digit_powers(digits,power);" "}") "}") "var raw = '.'.concat(digits.join(''));" "return raw.split(/0*$/)[0];" "})") - "deg_text_to_digits" (str "(function deg_text_to_digits(input) {" + "deg_text_to_digits" (str "(function LuxRT$deg_text_to_digits(input) {" "var output = new Array(64);" (str "for(var idx = input.length-1; idx >= 0; idx--) {" "output[idx] = parseInt(input.substring(idx, idx+1));" "}") "return output;" "})") - "deg_digits_lt" (str "(function deg_digits_lt(l,r) {" + "deg_digits_lt" (str "(function LuxRT$deg_digits_lt(l,r) {" (str "for(var idx = 0; idx < 64; idx++) {" (str "if(l[idx] < r[idx]) {" "return true;" @@ -746,7 +746,7 @@ "}") "return false;" "})") - "deg_digits_sub_once" (str "(function deg_digits_sub_once(target,digit,idx) {" + "deg_digits_sub_once" (str "(function LuxRT$deg_digits_sub_once(target,digit,idx) {" (str "while(true) {" (str "if(target[idx] > digit) {" (str "target[idx] = target[idx] - digit;" @@ -759,25 +759,25 @@ "}") "}") "})") - "deg_digits_sub" (str "(function deg_digits_sub(l,r) {" + "deg_digits_sub" (str "(function LuxRT$deg_digits_sub(l,r) {" (str "for(var idx = 63; idx >= 0; idx--) {" - "l = LuxRT.deg_digits_sub_once(l,r[idx],idx);" + "l = LuxRT$deg_digits_sub_once(l,r[idx],idx);" "}") "return l;" "})") "decodeD64" (let [failure (str "return " const-none ";")] - (str "(function decodeD64(input) {" - "input = LuxRT.clean_separators(input);" + (str "(function LuxRT$decodeD64(input) {" + "input = LuxRT$clean_separators(input);" (str "if(/^\\.\\d+$/.exec(input) && input.length <= 65) {" (str "try {" - (str "var digits = LuxRT.deg_text_to_digits(input.substring(1));") - "var output = LuxRT.makeI64(0,0);" + (str "var digits = LuxRT$deg_text_to_digits(input.substring(1));") + "var output = LuxRT$makeI64(0,0);" (str "for(var idx = 0; idx < 64; idx++) {" - "var power = LuxRT.deg_text_to_digits(idx);" - (str "if(LuxRT.deg_digits_lt(power,digits)) {" - (str "digits = LuxRT.deg_digits_sub(digits,power);" - "var powerBit = LuxRT.shlI64(LuxRT.makeI64(0,1),(63-idx));" - "output = LuxRT.orI64(output,powerBit);") + "var power = LuxRT$deg_text_to_digits(idx);" + (str "if(LuxRT$deg_digits_lt(power,digits)) {" + (str "digits = LuxRT$deg_digits_sub(digits,power);" + "var powerBit = LuxRT$shlI64(LuxRT$makeI64(0,1),(63-idx));" + "output = LuxRT$orI64(output,powerBit);") "}") "}") (str "return " (make-some "output") ";") @@ -793,36 +793,36 @@ }) (def ^:private io-methods - {"log" (str "(function log(message) {" + {"log" (str "(function LuxRT$log(message) {" "console.log(message);" (str "return " &&/unit ";") "})") - "error" (str "(function error(message) {" + "error" (str "(function LuxRT$error(message) {" "throw new Error(message);" (str "return null;") "})") }) (def ^:private text-methods - {"index" (str "(function index(text,part,start) {" - "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" + {"index" (str "(function LuxRT$index(text,part,start) {" + "var idx = text.indexOf(part,LuxRT$toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") (str "else {" - (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + (str "return " (make-some "LuxRT$fromNumberI64(idx)") ";") "}")) "})") - "lastIndex" (str "(function lastIndex(text,part,start) {" - "var idx = text.lastIndexOf(part,LuxRT.toNumberI64(start));" + "lastIndex" (str "(function LuxRT$lastIndex(text,part,start) {" + "var idx = text.lastIndexOf(part,LuxRT$toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") (str "else {" - (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") + (str "return " (make-some "LuxRT$fromNumberI64(idx)") ";") "}")) "})") - "clip" (str "(function clip(text,from,to) {" + "clip" (str "(function LuxRT$clip(text,from,to) {" (str "if(from.L > text.length || to.L > text.length) {" (str "return " const-none ";") "}" @@ -830,11 +830,11 @@ (str "return " (make-some "text.substring(from.L,to.L)") ";") "}") "})") - "replaceAll" (str "(function replaceAll(text,toFind,replaceWith) {" + "replaceAll" (str "(function LuxRT$replaceAll(text,toFind,replaceWith) {" "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") - "textChar" (str "(function textChar(text,idx) {" + "textChar" (str "(function LuxRT$textChar(text,idx) {" "var result = text.charAt(idx.L);" (str "if(result === '') {" (str "return " const-none ";") @@ -845,18 +845,18 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") - "textHash" (str "(function(input) {" + "textHash" (str "(function LuxRT$textHash(input) {" "var hash = 0;" (str "for(var i = 0; i < input.length; i++) {" "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" "}") - "return LuxRT.fromNumberI64(hash);" + "return LuxRT$fromNumberI64(hash);" "})") }) (def ^:private array-methods - {"arrayGet" (str "(function arrayGet(arr,idx) {" - "var temp = arr[LuxRT.toNumberI64(idx)];" + {"arrayGet" (str "(function LuxRT$arrayGet(arr,idx) {" + "var temp = arr[LuxRT$toNumberI64(idx)];" (str "if(temp !== undefined) {" (str "return " (make-some "temp") ";") "}" @@ -864,31 +864,31 @@ (str "return " const-none ";") "}") "})") - "arrayPut" (str "(function arrayPut(arr,idx,val) {" - "arr[LuxRT.toNumberI64(idx)] = val;" + "arrayPut" (str "(function LuxRT$arrayPut(arr,idx,val) {" + "arr[LuxRT$toNumberI64(idx)] = val;" "return arr;" "})") - "arrayRemove" (str "(function arrayRemove(arr,idx) {" - "delete arr[LuxRT.toNumberI64(idx)];" + "arrayRemove" (str "(function LuxRT$arrayRemove(arr,idx) {" + "delete arr[LuxRT$toNumberI64(idx)];" "return arr;" "})") }) (def ^:private bit-methods - (let [make-basic-op (fn [op] - (str "(function andI64(input,mask) {" - "return LuxRT.makeI64(input.H " op " mask.H, input.L " op " mask.L);" + (let [make-basic-op (fn [op name] + (str "(function " name "(input,mask) {" + "return LuxRT$makeI64(input.H " op " mask.H, input.L " op " mask.L);" "})"))] - {"andI64" (make-basic-op "&") - "orI64" (make-basic-op "|") - "xorI64" (make-basic-op "^") - "countI64" (str "(function countI64(input) {" + {"andI64" (make-basic-op "&" "LuxRT$andI64") + "orI64" (make-basic-op "|" "LuxRT$orI64") + "xorI64" (make-basic-op "^" "LuxRT$xorI64") + "countI64" (str "(function LuxRT$countI64(input) {" "var hs = (input.H).toString(2);" "var ls = (input.L).toString(2);" "var num1s = hs.concat(ls).replace(/0/g,'').length;" - "return LuxRT.fromNumberI64(num1s);" + "return LuxRT$fromNumberI64(num1s);" "})") - "shlI64" (str "(function shlI64(input,shift) {" + "shlI64" (str "(function LuxRT$shlI64(input,shift) {" "shift &= 63;" (str "if(shift === 0) {" "return input;" @@ -897,15 +897,15 @@ (str "if (shift < 32) {" "var high = (input.H << shift) | (input.L >>> (32 - shift));" "var low = input.L << shift;" - "return LuxRT.makeI64(high, low);" + "return LuxRT$makeI64(high, low);" "}" "else {" "var high = (input.L << (shift - 32));" - "return LuxRT.makeI64(high, 0);" + "return LuxRT$makeI64(high, 0);" "}") "}") "})") - "shrI64" (str "(function shrI64(input,shift) {" + "shrI64" (str "(function LuxRT$shrI64(input,shift) {" "shift &= 63;" (str "if(shift === 0) {" "return input;" @@ -914,16 +914,16 @@ (str "if (shift < 32) {" "var high = input.H >> shift;" "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return LuxRT.makeI64(high, low);" + "return LuxRT$makeI64(high, low);" "}" "else {" "var low = (input.H >> (shift - 32));" "var high = input.H >= 0 ? 0 : -1;" - "return LuxRT.makeI64(high, low);" + "return LuxRT$makeI64(high, low);" "}") "}") "})") - "ushrI64" (str "(function ushrI64(input,shift) {" + "ushrI64" (str "(function LuxRT$ushrI64(input,shift) {" "shift &= 63;" (str "if(shift === 0) {" "return input;" @@ -932,24 +932,24 @@ (str "if (shift < 32) {" "var high = input.H >>> shift;" "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return LuxRT.makeI64(high, low);" + "return LuxRT$makeI64(high, low);" "}" "else if(shift === 32) {" - "return LuxRT.makeI64(0, input.H);" + "return LuxRT$makeI64(0, input.H);" "}" "else {" "var low = (input.H >>> (shift - 32));" - "return LuxRT.makeI64(0, low);" + "return LuxRT$makeI64(0, low);" "}") "}") "})") })) (def ^:private lux-methods - {"clean_separators" (str "(function clean_separators(input) {" + {"clean_separators" (str "(function LuxRT$clean_separators(input) {" "return input.replace(/_/g,'');" "})") - "runTry" (str "(function runTry(op) {" + "runTry" (str "(function LuxRT$runTry(op) {" (str "try {" (str "return [1,'',op(null)];") "}" @@ -957,7 +957,7 @@ (str "return [0,null,ex.toString()];") "}") "})") - "programArgs" (str "(function programArgs() {" + "programArgs" (str "(function LuxRT$programArgs() {" (str "if(typeof process !== 'undefined' && process.argv) {" (str (str "var result = " const-none ";") "for(var idx = process.argv.length-1; idx >= 0; idx--) {" @@ -972,15 +972,15 @@ }) (def ^:private js-methods - {"jsSetField" (str "(function jsSetField(object, field, input) {" + {"jsSetField" (str "(function LuxRT$jsSetField(object, field, input) {" "object[field] = input;" "return object;" "})") - "jsDeleteField" (str "(function jsDeleteField(object, field) {" + "jsDeleteField" (str "(function LuxRT$jsDeleteField(object, field) {" "delete object[field];" "return object;" "})") - "jsObjectCall" (str "(function jsObjectCall(object, method, args) {" + "jsObjectCall" (str "(function LuxRT$jsObjectCall(object, method, args) {" "return object[method].apply(object, args);" "})") }) @@ -988,20 +988,16 @@ (def LuxRT "LuxRT") (def compile-LuxRT - (|do [:let [rt-object (str "{" (->> (merge lux-methods - adt-methods - i64-methods - n64-methods - d64-methods - text-methods - array-methods - bit-methods - io-methods - js-methods) - (map (fn [[key val]] - (str key ":" val))) - (interpose ",") - (reduce str "")) - "}")]] - (&&/save-js! LuxRT - (str "var " LuxRT " = " rt-object ";")))) + (&&/save-js! LuxRT + (->> (merge lux-methods + adt-methods + i64-methods + n64-methods + d64-methods + text-methods + array-methods + bit-methods + io-methods + js-methods) + (reduce (fn [prev [key val]] (str prev "var LuxRT$" key " = " val ";\n")) + "")))) -- cgit v1.2.3 From 75ee863cc5b2d59478fa20e81da8ac6654dcdff7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Mar 2017 16:12:37 -0400 Subject: - Fixed some bugs in the common procedures. --- luxc/src/lux/compiler/js/proc/common.clj | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index 907b6d512..cd67104f4 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -343,11 +343,11 @@ (defn ^:private compile-io-exit [compile ?values special-args] (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] =code (compile ?code)] - (return (str "(process && process.exit && process.exit(LuxRT$fromNumberI64(" =code ")))")))) + (return (str "(process && process.exit && process.exit(LuxRT$toNumberI64(" =code ")))")))) (defn ^:private compile-io-current-time [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT$toNumberI64(" "(new Date()).getTime()" ")")))) + (return (str "LuxRT$fromNumberI64(" "(new Date()).getTime()" ")")))) (defn ^:private compile-atom-new [compile ?values special-args] (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] @@ -377,7 +377,7 @@ (defn ^:private compile-process-concurrency-level [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT$fromNumberI64(1)")))) + (return (str "LuxRT$ONE")))) (defn ^:private compile-process-future [compile ?values special-args] (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] -- cgit v1.2.3 From 3ad92cceba0ebd2fa4b6ced5302d4a9290229e43 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 24 Mar 2017 16:29:13 -0400 Subject: - Added code for the special case of dividing by a 32-bit divisor. --- luxc/src/lux/compiler/js/rt.clj | 75 +++++++++++++++++++++++++++++++++++------ 1 file changed, 65 insertions(+), 10 deletions(-) (limited to 'luxc/src') diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index a70a59689..b2104cb1b 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -74,16 +74,16 @@ "return (i64.H * LuxRT$TWO_PWR_32) + LuxRT$getLowBitsUnsigned(i64);" "})") "fromNumberI64" (str "(function LuxRT$fromNumberI64(num) {" - (str "if (isNaN(num)) {" + (str "if(isNaN(num)) {" "return LuxRT$ZERO;" "}") - (str "else if (num <= -LuxRT$TWO_PWR_63) {" + (str "else if(num <= -LuxRT$TWO_PWR_63) {" "return LuxRT$MIN_VALUE_I64;" "}") - (str "else if ((num + 1) >= LuxRT$TWO_PWR_63) {" + (str "else if((num + 1) >= LuxRT$TWO_PWR_63) {" "return LuxRT$MAX_VALUE_I64;" "}") - (str "else if (num < 0) {" + (str "else if(num < 0) {" "return LuxRT$negateI64(LuxRT$fromNumberI64(-num));" "}") (str "else {" @@ -293,15 +293,15 @@ "var rem = LuxRT$subI64(LuxRT$mulI64(div,radix),input);" "return LuxRT$encodeI64(div).concat(rem.L+'');" "}") - "}" (str "else {" "return '-'.concat(LuxRT$encodeI64(LuxRT$negateI64(input)));" - "}")) + "}") + "}") ;; If input > 0 (str "var chunker = LuxRT$makeI64(0,1000000);" "var rem = input;" "var result = '';" - "while (true) {" + "while(true) {" (str "var remDiv = LuxRT$divI64(rem,chunker);" "var chunk = LuxRT$subI64(rem,LuxRT$mulI64(remDiv,chunker));" "var digits = (chunk.L >>> 0)+'';" @@ -310,7 +310,7 @@ "return digits.concat(result);" "}" "else {" - (str "while (digits.length < 6) {" + (str "while(digits.length < 6) {" "digits = '0' + digits;" "}") "result = '' + digits + result;" @@ -467,6 +467,57 @@ "return LuxRT$makeI64(tempInput[0],tempInput[1]);") "}") "})") + "divideOneWord" (str "(function LuxRT$divideOneWord(subject,param) {" + (str "var divLong = LuxRT$makeI64(0,param);" + ;; Special case of one word dividend + (str "if(subject.H === 0) {" + (str "var remValue = LuxRT$makeI64(0,subject.L);" + "var quotient = LuxRT$divI64(remValue,divLong);" + "var remainder = LuxRT$subI64(remValue,LuxRT$mulI64(quotient.L,divLong));" + "return [quotient,remainder];") + "}") + "var quotient = [0|0,0|0];" + ;; Normalize the divisor + "var shift = 32 - LuxRT$countI64(LuxRT$makeI64(0,param));" + "var rem = subject.H;" + "var remLong = LuxRT$makeI64(0,rem);" + (str "if(LuxRT$ltI64(remLong,divLong)) {" + "quotient[0] = 0|0;" + "}" + "else {" + "quotient[0] = LuxRT$divI64(remLong,divLong).L;" + "rem = LuxRT$subI64(remLong,LuxRT$mulI64(quotient[0],divLong)).L;" + "remLong = LuxRT$makeI64(0,rem);" + "}") + "var remBI = [subject.H,subject.L];" + "var xlen = 2;" + "var qWord = [0|0,0|0];" + (str "while(--xlen > 0) {" + "var dividendEstimate = LuxRT$orI64(LuxRT$shlI64(remLong,32),LuxRT$makeI64(0,remBI[2 - xlen]));" + (str "if(dividendEstimate >= 0) {" + "var highWord = LuxRT$divI64(dividendEstimate,divLong);" + "qWord[0] = highWord.L;" + "qWord[1] = LuxRT$subI64(dividendEstimate,LuxRT$mulI64(highWord,divLong)).L;" + "}" + "else {" + "LuxRT$divWord(qWord, dividendEstimate, param);" + "}") + "quotient[2 - xlen] = qWord[0];" + "rem = qWord[1];" + "remLong = LuxRT$makeI64(0,rem);" + "}") + ;; Unnormalize + (str "if(shift > 0) {" + "rem %= divisor;" + "remBI[0] = rem;" + "}" + "else {" + "remBI[0] = rem;" + "}") + "var quotI64 = LuxRT$normalizeBigInt(quotient);" + "var remI64 = LuxRT$makeI64(remBI[0],remBI[1]);" + "return [quotI64,remI64];") + "})") "divmodBigInt" (str "(function LuxRT$divmodBigInt(subject,param) {" (str "if(LuxRT$eqI64(param,LuxRT$ZERO)) {" "throw new Error('Cannot divide by zero!');" @@ -481,6 +532,10 @@ "return [LuxRT$ONE, LuxRT$ZERO];" "}") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (str "if (param.H === 0) {" + "return LuxRT$divideOneWord(subject,param.L);;" + "}") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; "var divisor = param;" "var remainder = subject.H === 0 ? [0|0,subject.L] : [0|0,subject.H,subject.L];" "var paramLength = param.H === 0 ? 1 : 2;" @@ -489,7 +544,7 @@ "var quotient = (limit === 1) ? [0|0] : [0|0,0|0];" ;; Normalize the divisor "var shift = 32 - LuxRT$countI64(LuxRT$makeI64(divisor.H,0));" - (str "if (shift > 0) {" + (str "if(shift > 0) {" "divisor = LuxRT$shlI64(divisor,shift);" "remainder = LuxRT$shiftLeftBigInt(remainder,shift);" "}") @@ -551,7 +606,7 @@ "remainder[j] = 0;" "var borrow = LuxRT$mulsubBigInt(remainder, divisor, qhat, paramLength, j);" ;; D5 Test remainder - (str "if (borrow + 0x80000000 > nh2) {" + (str "if((borrow + 0x80000000) > nh2) {" ;; D6 Add back "LuxRT$divadd(divisor, remainder, j+1);" "qhat--;" -- cgit v1.2.3