- Re-designed atomic operations as common procedures.

- Implemented atomic operations for the JVM.
- Basic Lux types no longer rely on JVM classes.

4 files changed, 144 insertions, 61 deletions

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" "<init>" "(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 [<name> <tag>]
+  (defn <name> [elem-type]
+    (&/$HostT <tag> (&/|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] <set-var> 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] <set-var> 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] <set-var> 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]