Carp/lisp/compiler.carp

;; Gotchas
;; * Unloading of function/dylib doesn't work after another function has linked to it during its compilation.
;; * Variable shadowing doesn't work properly when referencing itself

;; How to add forms
;; 1. Make the ast generator generate a new kind of AST :node for the form (see above)
;; 2. The AST node should generate new type vars for all places where the type is unknown
;; 3. Make the constraint generator generate type constraints for the node
;; 4. Extend the function (assign-types) that substitute type variables for concrete types in the AST
;; 5. TODO: Make the borrow checker know about the node, if needed
;; 6. Make the C generator spit out beautiful C for the AST node
;; 7. Profit!

(load-lisp (str carp-dir "lisp/error_codes.carp"))
(load-lisp (str carp-dir "lisp/compiler_helpers.carp"))
(load-lisp (str carp-dir "lisp/ast.carp"))
(load-lisp (str carp-dir "lisp/infer_types.carp"))
(load-lisp (str carp-dir "lisp/generate_names.carp"))
(load-lisp (str carp-dir "lisp/calculate_lifetimes.carp"))
(load-lisp (str carp-dir "lisp/builder.carp"))
(load-lisp (str carp-dir "lisp/func_deps.carp"))
(load-lisp (str carp-dir "lisp/generics.carp"))
(load-lisp (str carp-dir "lisp/structs.carp"))

(def platform-specifics
  (if (windows?)
    {:dylib-extension ".dll"
     :link-extension ".lib"
     :include-flag "/I"
     :linkdir-flag "/link /NOLOGO /LIBPATH:"}
    {:dylib-extension ".so"
     :link-extension ".so"
     :include-flag "-I"
     :linkdir-flag "-L"}))

(defn annotate-ast (ast)
  (annotate-ast-internal ast false nil))

(defn annotate-ast-internal (ast bake-deps func-signature-if-generic)
  (let [ast-func-deps (find-func-deps ast bake-deps)
        ast-typed (infer-types ast-func-deps func-signature-if-generic)
        ast-named (generate-names (copy {}) ast-typed)
        ast-lifetimes (calculate-lifetimes ast-named)
        ast-generics (visit-generic-funcs ast-lifetimes)
        ;;_ (println (str "ast:\n" ast-generics))
        ]
    ast-generics))

;; WARNING: These two helper functions don't know the name of the functions
;; so they will mess upp self-recursive functions since they will think that
;; they are refering to other functions and bake those:
(defn ann (lambda) (annotate-ast (lambda-to-ast (code lambda))))
(defn sign (lambda) (:type (ann lambda)))

(defn check-for-ref-return (ast)
  (let [t (:type ast)]
    (when (ref? (nth t 2)) (error (str "Return type of function '" (:name ast) "' is a reference: " (pretty-signature t))))))

(def header-files (list "\"functions.h\"" "\"shared.h\""))

(def baked-funcs {})
(def baked-primops ())

(defn add-func! (func-name func-proto func-dylib)
  (swap! baked-funcs (fn (fs) (assoc fs func-name {:func-name func-name
                                                   :func-proto func-proto
                                                   :func-dylib func-dylib}))))

(defn func-baked? [func-name]
  (not (nil? (get-maybe baked-funcs func-name))))

(def log-unloading-of-dylibs false)

;; Takes the name of a function and unloads it if it is in the list of baked functions
(defn unload-if-necessary (func-name)
  (let [baked-func (get-maybe baked-funcs func-name)]
    (when (not (nil? baked-func))
      (let [dylib (get baked-func :func-dylib)]
        (do (when log-unloading-of-dylibs
              (println (str "Unloading " dylib " for function " func-name ".")))
            (unload-dylib dylib)
            (dict-remove! baked-funcs func-name)
            )))))

(defn re-lambda-fy [func-name]
  (let [function-symbol (symbol func-name)
        func (eval function-symbol)]
    (if (foreign? func)
      (let [func-code (meta-get func :code)]
        (do
          ;;(println (str "re-lambda-fy:ing baked function '" func-name "' using original code: " func-code))
          (eval (list 'def (symbol func-name) func-code))
          ))
      (do
        ;;(println (str "re-lambda-fy will ignore non-baked function: " func-name))
        :ignore))))

(defn re-compile [func-name]
  (let [function-symbol (symbol func-name)
        func (eval function-symbol)]
      (if (lambda? func)
        (let [func-code (code (eval (symbol func-name)))]
          (do
            ;;(println (str "Compiling dynamic (lambda) function '" func-name "' using its code: " func-code))
            (bake-internal (new-builder) func-name func-code '() false)))
        (do
          ;;(println (str "re-compile will ignore non-lambda: " func))
          :ignore))))

(defn unload-all-baked ()
  (join "\n" (map (fn (x) (str (unload-dylib (:func-dylib x)))) (values baked-funcs))))

(def types {})

(defn add-type! [type-name type-definition]
  (swap! types (fn (ts) (assoc ts type-name {:type-name type-name
                                             :type-definition type-definition}))))

;; Saves the signatures of all the baked functions to a header file so that they can include each other
(defn save-function-prototypes ()
  (save (str out-dir "functions.h")
        (str
         "#include <shared.h>\n"
         "//Types:\n"
         (join "\n" (map :type-definition (reverse (values types))))
         "\n\n//Functions:\n"
         (join "\n" (map :func-proto (values baked-funcs))))))

;; Keys:   Names of functions (strings)
;; Values: A list of all the functions that depend on this particular function
(def function-dependency-graph {})

;; Print a nice version of the function dependency graph
(defn graph []
  (println (str "- FUNCTION DEPENDENCY GRAPH-\n\n"
                (join "\n"
                      (map2 (fn [k v] (str k " <~ " (join ", " v)))
                            (keys function-dependency-graph)
                            (values function-dependency-graph)))
                "\n")))

(defn add-function-dependency! [target-function name-of-depending-function]
  (let [current-list (get-maybe function-dependency-graph target-function)]
    (reset! function-dependency-graph (assoc function-dependency-graph target-function (cons name-of-depending-function current-list)))))

(defn link-libs (dependencies)
  (join " " (map (fn (f) (str out-dir (c-ify-name (str f)) (:link-extension platform-specifics))) dependencies)))

(defn include-paths ()
  (str (:include-flag platform-specifics) "/usr/local/include " (:include-flag platform-specifics) carp-dir "/shared"))

(defn lib-paths ()
  (if (windows?)
    ""
    (str (:linkdir-flag platform-specifics) "/usr/local/lib/ -lglfw3")))

(defn framework-paths ()
  (if (windows?)
    ""
    "-framework OpenGL -framework Cocoa -framework IOKit"))

(def out-dir "./")
(def echo-signature-after-bake false)

(defn remove-non-user-defined-deps (func-deps)
  (let [func-names (keys baked-funcs)]
    (filter (fn (dep) (contains? func-names (str dep))) func-deps)))
;; (filter (fn [dep] (meta-get (eval dep) :user-defined)) func-deps)

(defn func-to-annotated-ast (func-name func-code func-signature-if-generic)
  (let [ast (lambda-to-ast func-code)
        ast-named (assoc ast :name func-name)
        ast-annotated (annotate-ast-internal ast-named true func-signature-if-generic)
        _ (check-for-ref-return ast-annotated)]
    ast-annotated))

(defn generic-type? [t]
  (match (type t)
    :string true
    :keyword false
    :list (any true? (map generic-type? t))
    x (error (str "Invalid type in 'generic-type?': " (prn x)))))

(defn generic-function? [ast]
  (match (:type ast)
    (:fn arg-types ret-type) (or (any generic-type? arg-types) (generic-type? ret-type))
    x (error (str "Can't match " x " in generic-function?"))))

;; Takes a function name and the list representation of the lambda
(defn bake-internal [builder func-name func-code external-deps exe]
  (let [ast-annotated (func-to-annotated-ast func-name func-code nil)]
    (if (generic-function? ast-annotated)
      (do
        ;;(println (str "bake found generic function: " func-name))
        (let [func-def (eval (symbol func-name))]
          (do
            (meta-set! func-def :generic true)
            (meta-set! func-def :signature (:type ast-annotated))
            (def ast ast-annotated)
            (def s (pretty-signature (:type ast-annotated)))
            (if echo-signature-after-bake
              (println (str func-name " : " s))
              nil))))
      (bake-internal-common ast-annotated builder func-name func-code external-deps exe))))

(defn bake-generic-func-internal [builder func-name func-code external-deps exe func-signature]
  (let [ast-annotated (func-to-annotated-ast func-name func-code func-signature)]
    (if (generic-function? ast-annotated)
      (error (str "Failed to concretize generic function " func-name ":\n" ast-annotated))
      (bake-internal-common ast-annotated builder func-name func-code external-deps exe))))

(defn run-compiler [c-func-name c-file-name total-dependencies exe]
  (if (windows?)
    (run-cl c-func-name c-file-name total-dependencies exe)
    (run-clang c-func-name c-file-name total-dependencies exe)))

(defn run-clang [c-func-name c-file-name total-dependencies exe]
  (let [clang-command (str "clang -DAPI= "
                           (if exe
                             (str "-o " out-dir "exe ")
                             (str "-shared -g -o " out-dir c-func-name ".so "))
                           c-file-name " "
                           (include-paths)  " "
                           (lib-paths) " "
                           (framework-paths) " "
                           (link-libs total-dependencies))]
    (do
      (def cmd clang-command)
      (system clang-command))))

(defn get-depending-funcs-recursively [func-name]
  (let [depending-funcs (get-maybe function-dependency-graph func-name)]
    (concat depending-funcs (mapcat get-depending-funcs-recursively depending-funcs))))

(defn bake-function-and-its-depending-funcs [func-name external-deps]
  (if (foreign? (eval (symbol func-name)))
    :already-baked
    (let [functions-depending-on-this-function (set (get-depending-funcs-recursively func-name))]
      (do
        ;;(println (str "Baking '" func-name "' and its users: " (join ", " functions-depending-on-this-function)))
        (unload-if-necessary func-name)
        (map unload-if-necessary functions-depending-on-this-function)
        (map re-lambda-fy functions-depending-on-this-function)
        (map re-compile functions-depending-on-this-function)
        (if (foreign? (eval (symbol func-name)))
          (do
            ;;(println (str "The functions depending on " func-name " already made it recompile, no need to bake again."))
            :OK)
          (bake-internal (new-builder) func-name (code (eval (symbol func-name))) external-deps false))))))

(defn run-cl [c-func-name c-file-name total-dependencies exe]
  (let [common-options "/nologo /DWIN32 /Od /Zi /MDd /Fe"
        cl-command (str "cl.exe "
                           (if exe
                             (str common-options out-dir c-func-name ".exe ")
                             (str "/DAPI=__declspec(dllexport) /LDd " common-options out-dir c-func-name ".dll "))
                           c-file-name " "
                           (include-paths)  " "
                           (lib-paths) " "
                           (framework-paths) " "
                           (link-libs total-dependencies))]
    (do
      (println cl-command)
      (def cmd cl-command)
      (system cl-command))))

;; Do the part that is common between baking normal functions and generic functions
(defn bake-internal-common [ast-annotated builder func-name func-code external-deps exe]
  (let [builder-with-headers (builder-add-headers builder header-files)
        builder-fns (builder-visit-ast builder-with-headers ast-annotated func-name)
        builder-final (if (and exe (not (= func-name "main")))
                        (builder-add-main-function builder-fns (c-ify-name func-name))
                        builder-fns)
        c-program-string (builder-merge-to-c builder-final)
        proto (get-function-prototype ast-annotated func-name)
        c-func-name (c-ify-name func-name)
        c-file-name (str out-dir c-func-name ".c")
        total-dependencies (set (concat (remove-non-user-defined-deps (:func-deps ast-annotated)) external-deps))
        t (get ast-annotated :type)
        ]
    (do
      ;; (println (str "External deps for " func-name ": " (join ", " external-deps)))
      ;; (println (str "Func deps for " func-name ": " (join ", " (:func-deps ast-annotated))))
      ;; (println (str "Total deps for " func-name ": " (join ", " total-dependencies)))
      (map (fn [dep] (add-function-dependency! (str dep) func-name)) total-dependencies)
      (def ast ast-annotated)
      (def c c-program-string)
      ;;(println (str "Will save and compile: '" func-name "' with c-func-name '" c-func-name "' and signature: " t))
      (save-and-compile func-name t c-func-name c-file-name c-program-string proto total-dependencies exe)
      (meta-set! (eval (symbol func-name)) :code func-code))))

(defn save-and-compile [func-name t c-func-name c-file-name c-program-string proto total-dependencies exe]
  (match t
    (:fn arg-types return-type) (do
                                  (save-function-prototypes)
                                  (save c-file-name c-program-string)
                                  (run-compiler c-func-name c-file-name total-dependencies exe)
                                  (unload-if-necessary func-name)
                                  (if exe
                                    :exe-done
                                    (do
                                      (def out-lib (load-dylib (str out-dir c-func-name (:dylib-extension platform-specifics))))
                                      (register out-lib c-func-name arg-types return-type)
                                      (add-func! func-name proto out-lib)
                                      (let [f (eval (read func-name))
                                            sig (signature f)]
                                        (do (when (nil? sig) (error (str "No signature on function " f)))
                                            (def s (pretty-signature sig))
                                            (when echo-signature-after-bake (println (str func-name " : " s)))
                                            f)))))
    _ (error "Must bake function with type (:fn ...)")))

;; Bake a function in the current environment, just give it's symbol
(defmacro bake (func-symbol)
  (list 'bake-function-and-its-depending-funcs (str func-symbol) '()))

(defmacro bake-exe (func-symbol)
  (list 'bake-internal (new-builder) (str func-symbol) (list 'code func-symbol) '() true))

(defmacro bake* (func-symbol dependencies)
  (list 'bake-internal (new-builder) (str func-symbol) (list 'code func-symbol) dependencies false))

(defmacro bake-exe* (func-symbol dependencies)
  (list 'bake-internal (new-builder) (str func-symbol) (list 'code func-symbol) dependencies true))

(defn clean ()
  (if (windows?)
    (do
      (system "del functions.h")
      (system "del *.dll")
      (system "del *.exp")
      (system "del *.lib")
      (system "del *.pdb")
      (system "del *.ilk")
      (system "del *.obj"))
    (do
      (system "rm functions.h")
      (system "rm *.so")
      (system "rm *.c")
      (system "rm -r *.dSYM"))))