builder.carp

(def slim-code-generation true)

;; Creates a C code builder which allows for out-of-order generation of C from the AST
(defn new-builder []
  {:headers ()
   :functions ()
   :deps ()
   :main ()})

(defn builder-add [builder category block]
  (update-in builder (list category) (fn (blocks) (set (cons-last blocks block)))))

(defn builder-add-headers [builder files]
  (reduce (fn (b file) (builder-add b :headers (str "#include " file)))
          builder
          files))

;; Takes a completed C code builder and returns its string with C code
(defn builder-merge-to-c [builder]
  (let [funcs (:functions builder)
        headers (:headers builder)
        main (:main builder)]
    (str (join "\n\n"
               (list (join "\n" headers)
                     (join "\n\n" funcs)
                     (join "\n\n" main)))
         "\n")))

(def indent-level 1)

(defn indent []
  (join "" (replicate "  " indent-level)))

(defn indent-in! []
  (swap! indent-level inc))

(defn indent-out! []
  (swap! indent-level dec))

(defn free-variables [free-list deps]
  (do
    ;;(println (str "free-list: " free-list))
    (map (fn [t] (bake-generic-primop-auto "delete" (list :fn (list t) :void))) (map :type free-list))
    (join "" (map (fn (variable)
                    (let [delete-signature (list :fn (list (:type variable)) :void)
                          delete-fn-name (generic-name "delete" delete-signature)]
                      (do
                        (dict-set! deps :mutable-value (cons delete-fn-name (:mutable-value deps)))
                        (str (indent) (c-ify-name delete-fn-name) "(" (c-ify-name (:name variable)) ");\n"))))
                  free-list))))

(defn ensure-function-type [t]
  (match t
    (:fn arg-types return-type) (let [func-type-name (str "Fn_" (join "_" (map type-build-no-star arg-types))
                                                          "_" (type-build-no-star return-type))]
                                  (do (if (has-key? graph func-type-name)
                                        (do ;;(println (str "Ignoring " func-type-name))
                                            func-type-name)
                                        (do ;;(println (str "Adding function type " func-type-name))
                                          (graph/add-node! :function-type
                                                           func-type-name
                                                           (str "typedef " (type-build return-type)
                                                                "(*" func-type-name ")("
                                                                (join "," (map type-build arg-types))
                                                                ");"
                                                                ;;" // ensure function type " (str t)
                                                                )
                                                           "" ;; no body
                                                           "" ;; group
                                                           nil ;; dylib ptr
                                                           () ;; (struct-groups-in-type t) ;; deps
                                                           (calculate-dependency-level t) ;; (log (str func-type-name " dep lvl: ")
                                                           )
                                            func-type-name))))

    _ (error "Can't match t in ensure-function-type: " t)))

(defn struct-groups-in-type [t]
  (if (list? t)
    (set (mapcat struct-groups-in-type t))
    (if (struct-type? t)
      (list (name t))
      ())))

(defn visit-arg-explicit [c arg deps]
  (let [result (visit-form c arg true deps)]
    (str-append! c (str (indent) (type-build (:type arg)) " " (c-ify-name (:arg-name arg)) " = " (get result :c) ";\n"))))

(defn visit-args-explicit [c args deps]
  (let []
    (do
      ;;(println "visit args:" args)
      (map (fn (arg) (visit-arg-explicit c arg deps)) args)
      (map (fn (arg) {:c (:arg-name arg)}) args))))

(defn inlined-literal? [ast]
  (and* (= :literal (:node ast))
        (contains? '(:int :float :double :bool (:ref :string)) (:type ast))))

(defn inlined-lookup? [ast]
  (= :lookup (:node ast)))

(defn inlined-binop? [ast]
  (= :binop (:node ast)))

;; Print Objs in a way that the C compiler accepts
(defn c-prn [x]
  (match (type x)
    :char (str "'" x "'") ;; chars are written like this in Carp: \e but like this: 'e' in C.
    _ (prn x)))

;; New version of visit arg that generates slimmer code (no intermediate arg variables)
(defn visit-arg-slim [c arg deps]
  (let [arg-name (:arg-name arg)
        arg-type (:type arg)
        result (visit-form c arg true deps)]
    (match (:node arg)

      :lookup (do ;;(println (str "Arg " arg-name " is lookup."))
                  {:c (c-ify-name (str (:value arg)))})

      :literal (do ;;(println (str "Arg " arg-name " is literal."))
                   {:c (c-prn (:value arg))})

      _ (let [result-name (get-maybe arg :result-name)]
          (if (nil? result-name)
            (do (str-append! c (str (indent) (type-build arg-type) " " (c-ify-name arg-name) " = " (:c result) ";\n"))
                {:c (:arg-name arg)})
            {:c result-name}))

      )))

(defn visit-args-slim [c args deps]
  (let []
    (do
      ;(println (str "visit args slim:\n" args))
      (map (fn (arg) (visit-arg-slim c arg deps)) args))))

(defn visit-let-bindings (c bindings deps)
  (map (fn (b) (let [value-result (visit-form c (:value b) false deps)]
                 (str-append! c (str (indent) (type-build (:type b)) " " (c-ify-name (str (:name b))) " = " (:c value-result) ";\n"))))
       bindings))

(defn visit-form [c form toplevel deps]
  (do
    ;;(println (str "\nvisit-form:\n" form))
    (match (get form :node)

           :binop (let [result-a (visit-form c (get form :left) false deps)
                        result-b (visit-form c (get form :right) false deps)]
                    {:c (str (if toplevel "" "(") (:c result-a) " " (:op form) " " (:c result-b) (if toplevel "" ")"))})

           :literal (let [val (:value form)
                          result-name (get-maybe form :result-name)]
                      (if (or (inlined-literal? form) (nil? result-name))
                        {:c (c-prn val)}
                        (do
                          (str-append! c (str (indent)
                                              (type-build (:type form)) " "
                                              (:result-name form) " = "
                                              (c-prn val) ";\n"))
                          {:c (:result-name form)})))
           
           :lookup (let [val (:value form)]
                     {:c (c-ify-name (name val))})

           :ref (let [expr (:expr form)
                      result (visit-form c expr toplevel deps)]
                  result)

           :reset (let [expr (:expr form)
                        symbol (:value (:symbol form))
                        result (visit-form c expr toplevel deps)
                        t (:type expr)]
                    (do
                      ;;(str-append! c (str (indent) "printf(\"address of " symbol " = %p\\n\", &" symbol ");\n"))
                      (when (managed-type? t)
                        (do
                          (str-append! c (str (indent) "// free '" symbol "' before assigning to it:\n"))
                          (str-append! c (str (indent) "if(" (c-ify-name (str symbol)) ") {\n"))
                          (indent-in!)
                          (str-append! c (free-variables (list {:name (c-ify-name (str symbol)) :type t}) deps))
                          (indent-out!)
                          (str-append! c (str (indent) "}\n"))))
                      (str-append! c (str (indent) (c-ify-name (str symbol)) " = " (:c result) ";\n"))
                      {:c ""}))

           :if (let [n (get form :result-name)
                     if-expr (visit-form c (get form :expr) true deps)]
                 (do (if (= :void (:type form))
                       () ;; no result variable needed
                       (str-append! c (str (indent) (type-build (:type form)) " " n ";\n")))
                     
                     (str-append! c (str (indent) "if("))
                     (str-append! c (:c if-expr))
                     (str-append! c (str ")"))
                     
                     ;; true-block begins
                     (str-append! c " {\n")
                     (indent-in!)
                     (let [result-a (visit-form c (:if-true form) true deps)]
                       (do
                         (str-append! c (free-variables (get-maybe form :free-left) deps))
                         (if (= :void (:type form))
                           () ;; no-op
                           (str-append! c (str (indent) n " = " (get result-a :c) ";\n")))
                         (indent-out!)
                         (str-append! c (str (indent) "} else {\n"))))
                     
                     (indent-in!) ;; false-block-begins
                     (let [result-b (visit-form c (:if-false form) true deps)]
                       (do
                         (str-append! c (free-variables (get-maybe form :free-right) deps))
                         (if (= :void (:type form))
                           () ;; no-op
                           (str-append! c (str (indent) n " = " (get result-b :c) ";\n")))
                         (indent-out!)
                         (str-append! c (str (indent) "}\n"))))
                     {:c n}))
           
           :app (let [head (get form :head)
                      func-name (get head :value)
                      c-func-name (c-ify-name (str func-name))
                      n (:result-name form)
                      ;;_ (println (str "c before call to " func-name ":\n" c))
                      arg-results ((if slim-code-generation visit-args-slim visit-args-explicit) c (get form :tail) deps)
                      ;;_ (println (str "c after call to " func-name ":\n" c))
                      arg-vars (map :c arg-results)
                      t (:type form)]
                  (do
                    (if (= :void t)
                      (do (str-append! c (str (indent) c-func-name "(" (join ", " arg-vars) ");\n"))
                          {:c n})
                      ;;{:c (str c-func-name "(" (join ", " arg-vars) ")")}
                      (do (str-append! c (str (indent) (type-build t) " " n " = " c-func-name "(" (join ", " arg-vars) ");\n"))
                          {:c n})
                      )))

           :do (let [forms (:forms form)
                     ;_ (println (str "forms:\n" forms))
                     results (map (fn (x) (visit-form c x toplevel deps)) forms)]
                 {:c (:c (last results))})

           :let (let [n (:result-name form)]
                  (do (if (= :void (:type form))
                        () ;; nothing
                        (str-append! c (str (indent) (type-build (:type form)) " " n ";\n")))
                      (str-append! c (str (indent) "{\n"))
                      (indent-in!)
                      (let [body (:body form)
                            _ (visit-let-bindings c (:bindings form) deps)
                            result (visit-form c body false deps)]
                        (do (str-append! c (free-variables (get-maybe form :free) deps))
                            (if (= :void (:type form))
                              ()
                              (str-append! c (str (indent) n " = " (:c result) ";\n")))))
                      (indent-out!)
                      (str-append! c  (str (indent) "}\n"))
                      {:c n}))

           :while (let [while-expr (visit-form c (get form :expr) true deps)
                        while-expr-name (:while-expr-name form)]
                    (do (str-append! c (str (indent) (type-build (get-in form '(:expr :type))) " " while-expr-name " = " (get while-expr :c) ";\n"))
                        (str-append! c (str (indent) "while(" while-expr-name ") {\n"))
                        (indent-in!)
                        (let [body (:body form)]
                          (visit-form c body false deps))
                        (let [while-expr-again (visit-form c (get form :expr) true deps)]
                          (do
                            (str-append! c (free-variables (get-maybe form :free) deps))
                            (str-append! c (str (indent) while-expr-name " = " (get while-expr-again :c) ";\n"))
                            ))
                        (indent-out!)
                        (str-append! c  (str (indent) "}\n"))))

           :c-code (do
                     ;;(str-append! c )
                     {:c (:code form)})

           :null {:c "NULL"}

           :array (let [n (:result-name form)
                        inner-type (nth (:type form) 1)
                        t (type-build inner-type)
                        t-no-star (c-ify-name (type-build-no-star inner-type))
                        vals (:values form)
                        arg-results (map (fn (arg) (visit-arg-slim c arg deps)) vals)
                        arg-vars (map :c arg-results)]
                    (do (str-append! c (str (indent) "Array* " n " = malloc(sizeof(Array));\n"
                                            (indent) n "->count = " (count vals) ";\n"
                                            (indent) n "->data = malloc(sizeof(" t ") * " (count vals) ");\n"
                                            (indent) t " *casted" n " = " n "->data;\n"
                                            (join "\n" (map2 (fn [arg-name index]
                                                               (str (indent) "casted" n "[" index "] = " arg-name ";"))
                                                             arg-vars
                                                             (range 0 (count arg-vars))))
                                            "\n"))
                        {:c n}))
           
           x (error (str "visit-form failed to match " x)))))

(defn arg-list-build [args]
  (join ", " (map (fn (arg) (str (type-build (get arg :type)) " " (c-ify-name (str (:name arg)))))args)))

(defn visit-function [builder ast func-name]
  (let [t (:type ast)
        _ (when (not (list? t)) (error "Can't generate code for function, it's type is not a list."))
        return-type (nth t 2)
        args (get ast :args)
        body (get ast :body)
        c (copy "") ;; mutable string holding the resulting C code for the function
        deps (copy {:mutable-value (get-maybe ast :deps)}) ;; HACK: passing around a dict so that the mutation of the cdr (in the binding pair) will work. Add set-cdr! to list instead?
        result (visit-form c body true deps)
        result-var-name (:result-name ast)
        ret-type (get-in ast '(:type 2))]
    (do
      ;;(println "visit-function: \n" ast)
      (let [code (str "API " (type-build return-type) " " (c-ify-name func-name)
                      "(" (arg-list-build args) ") {\n"
                      c
                      (if (= :void ret-type)
                        ""
                        (str (indent) (type-build ret-type) " " result-var-name " = " (get result :c) ";\n")) ;; TODO: evaluate if this extra step is needed
                      (free-variables (get-maybe ast :free) deps)
                      (if (= :void (:type body))
                        "" ;; no return
                        (str (indent) "return " result-var-name ";\n"))
                      "}")]
        {:builder (builder-add builder :functions code)
         :deps (:mutable-value deps)}))))

(defn get-function-prototype [ast func-name]
  (let [t (get ast :type)
        return-type (nth t 2)
        args (get ast :args)]
    (str "API " (type-build return-type) " " (c-ify-name func-name) "(" (arg-list-build args) ");")))

(defn builder-visit-ast [builder ast func-name]
  (match (get ast :node)
         :function (visit-function builder ast func-name)
         x (error (str "Can't match :ast '" x "' in builder-visit-ast."))))