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') 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