diff options
Diffstat (limited to 'cljcc-compiler/src/cljcc/tacky.clj')
| -rw-r--r-- | cljcc-compiler/src/cljcc/tacky.clj | 687 |
1 files changed, 687 insertions, 0 deletions
diff --git a/cljcc-compiler/src/cljcc/tacky.clj b/cljcc-compiler/src/cljcc/tacky.clj new file mode 100644 index 0000000..be60841 --- /dev/null +++ b/cljcc-compiler/src/cljcc/tacky.clj @@ -0,0 +1,687 @@ +(ns cljcc.tacky + (:require + [cljcc.lexer :as l] + [cljcc.util :as u] + [cljcc.parser :as p] + [cljcc.exception :as exc] + [cljcc.symbol :as sym] + [malli.core :as m] + [malli.dev.pretty :as pretty] + [cljcc.analyze.typecheck :as tc] + [cljcc.analyze.core :as a] + [cljcc.schema :as s])) + +(defn- variable + ([] + (variable "var")) + ([identifier] + {:type :variable + :value (u/create-identifier! (str identifier))})) + +(defn parsed-var->tacky-var [v] + {:type :variable + :value (:identifier v)}) + +(defn tacky-var [identifier] + {:type :variable + :value identifier}) + +(defn- label + ([] (label "label")) + ([ident] (u/create-identifier! ident))) + +(defn- const-int [v] + {:type :int + :value v}) + +(defn- const-long [v] + {:type :long + :value v}) + +(defn constant [const-value] + {:type :constant + :value const-value}) + +(defn- unary-operator + "Converts parser's unary operator to tacky representation." + [op] + (condp = op + :complement :bit-not + :hyphen :negate + :logical-not :logical-not + (exc/tacky-error "Invalid unary operator." {op op}))) + +(defn- assignment-operator->binary-operator + "Converts parser assignment operator to binary operator keyword." + [op] + (condp = op + :assignemnt :assignemnt + :assignment-plus :plus + :assignment-multiply :multiply + :assignment-minus :hyphen + :assignment-divide :divide + :assignment-mod :remainder + :assignment-bitwise-and :ampersand + :assignment-bitwise-or :bitwise-or + :assignment-bitwise-xor :bitwise-xor + :assignment-bitwise-left-shift :bitwise-left-shift + :assignment-bitwise-right-shift :bitwise-right-shift + (exc/tacky-error "Invalid assignment operator." op))) + +(defn- binary-operator + "Converts parser's binary operator to tacky representation." + [binop] + (condp = binop + :plus :add + :hyphen :sub + :multiply :mul + :divide :div + :remainder :mod + :equal-to :equal + :not-equal-to :not-equal + :less-than :less-than + :greater-than :greater-than + :less-than-equal-to :less-or-equal + :greater-than-equal-to :greater-or-equal + :ampersand :bit-and + :bitwise-or :bit-or + :bitwise-xor :bit-xor + :bitwise-right-shift :bit-right-shift + :bitwise-left-shift :bit-left-shift + (exc/tacky-error "Invalid binary operator." binop))) + +;;;; Instructions + +(defn- unary-instruction [op src dst] + {:type :unary + :unary-operator op + :dst dst + :src src}) + +(defn- binary-instruction [op src1 src2 dst] + {:type :binary + :binary-operator op + :src1 src1 + :src2 src2 + :dst dst}) + +(defn- return-instruction [val] + {:type :return + :val val}) + +(defn- sign-extend-instruction [src dst] + {:type :sign-extend + :src src + :dst dst}) + +(defn- truncate-instruction [src dst] + {:type :truncate + :src src + :dst dst}) + +(defn- zero-extend-instruction [src dst] + {:type :zero-extend + :src src + :dst dst}) + +(defn- double-to-int-instruction [src dst] + {:type :double-to-int + :src src + :dst dst}) + +(defn- double-to-uint-instruction [src dst] + {:type :double-to-uint + :src src + :dst dst}) + +(defn- int-to-double-instruction [src dst] + {:type :int-to-double + :src src + :dst dst}) + +(defn- uint-to-double-instruction [src dst] + {:type :uint-to-double + :src src + :dst dst}) + +(defn- copy-instruction [src dst] + {:type :copy + :src src + :dst dst}) + +(defn- jump-instruction [target] + {:type :jump + :identifier target}) + +(defn- jump-if-zero-instruction [condition target] + {:type :jump-if-zero + :identifier target + :val condition}) + +(defn- jump-if-not-zero-instruction [condition target] + {:type :jump-if-not-zero + :identifier target + :val condition}) + +(defn- label-instruction [identifier] + {:type :label + :identifier identifier}) + +(defn- fun-call-instruction [identifier arguments dst] + {:type :fun-call + :identifier identifier + :arguments arguments + :dst dst}) + +;;;; Expression handlers + +;; Timothy Baldridge, Data all the ASTs +(defn postwalk [ast f] + (f (reduce + (fn [acc key] + (let [value (get acc key)] + (if (vector? value) + (assoc acc key (doall (map (fn [node] (postwalk node f)) + value))) + (assoc acc key (postwalk value f))))) + ast + (:children ast)))) + +(defn- add-var-to-symbol [var var-type symbols] + (swap! symbols assoc (:value var) {:type var-type + :attribute (sym/local-attribute)})) + +(defmulti exp-handler + (fn [exp _symbols] + (:exp-type exp))) + +(defmethod exp-handler :default + [_ _] + {:instructions []}) + +(defmethod exp-handler :constant-exp + [exp _] + {:val (constant (:value exp))}) + +(defmethod exp-handler :variable-exp + [exp _] + {:val (tacky-var (:identifier exp))}) + +(defmethod exp-handler :cast-exp + [{:keys [target-type value typed-inner]} symbols] + (if (= target-type (tc/get-type typed-inner)) + value + (let [dst (variable "cast_") + _ (add-var-to-symbol dst target-type symbols) + inner-type (tc/get-type typed-inner) + {res :val + insts :instructions} value + cast-inst (cond + (u/type-double? target-type) (if (u/type-signed? inner-type) + (int-to-double-instruction res dst) + (uint-to-double-instruction res dst)) + (u/type-double? inner-type) (if (u/type-signed? target-type) + (double-to-int-instruction res dst) + (double-to-uint-instruction res dst)) + (= (u/get-type-size target-type) + (u/get-type-size inner-type)) (copy-instruction res dst) + (< (u/get-type-size target-type) + (u/get-type-size inner-type)) (truncate-instruction res dst) + (u/type-signed? inner-type) (sign-extend-instruction res dst) + :else (zero-extend-instruction res dst))] + {:val dst + :instructions (flatten [insts cast-inst])}))) + +(defmethod exp-handler :unary-exp + [exp symbols] + (let [{src :val + insts :instructions} (:value exp) + op (unary-operator (:unary-operator exp)) + dst (variable (str "unary_result_" op)) + _ (add-var-to-symbol dst (tc/get-type exp) symbols) + inst (unary-instruction op src dst)] + {:val dst + :instructions (flatten [insts inst])})) + +(defn logical-and-binary-handler + [exp symbols] + (let [{v1 :val + insts1 :instructions} (:left exp) + {v2 :val + insts2 :instructions} (:right exp) + res (variable "and_result") + _ (add-var-to-symbol res (tc/get-type exp) symbols) + false-label (label "and_false") + end-label (label "and_end")] + {:val res + :instructions (flatten [insts1 + (jump-if-zero-instruction v1 false-label) + insts2 + (jump-if-zero-instruction v2 false-label) + (copy-instruction (constant (const-int 1)) res) + (jump-instruction end-label) + (label-instruction false-label) + (copy-instruction (constant (const-int 0)) res) + (label-instruction end-label)])})) + +(defn logical-or-binary-handler + [exp symbols] + (let [{v1 :val + insts1 :instructions} (:left exp) + {v2 :val + insts2 :instructions} (:right exp) + res (variable "or_result") + _ (add-var-to-symbol res (tc/get-type exp) symbols) + false-label (label "or_false") + end-label (label "or_end")] + {:val res + :instructions (flatten [insts1 + (jump-if-not-zero-instruction v1 end-label) + insts2 + (jump-if-not-zero-instruction v2 end-label) + (copy-instruction (constant (const-int 0)) res) + (jump-instruction false-label) + (label-instruction end-label) + (copy-instruction (constant (const-int 1)) res) + (label-instruction false-label)])})) + +(defn binary-exp-handler + [exp symbols] + (let [{v1 :val + insts1 :instructions} (:left exp) + {v2 :val + insts2 :instructions} (:right exp) + op (binary-operator (:binary-operator exp)) + dst (variable (str "binary_result_" op)) + _ (add-var-to-symbol dst (tc/get-type exp) symbols) + binary-inst (binary-instruction op v1 v2 dst)] + {:val dst + :instructions (flatten [insts1 + insts2 + binary-inst])})) + +(defmethod exp-handler :binary-exp + [exp symbols] + (let [op (:binary-operator exp)] + (condp = op + :logical-and (logical-and-binary-handler exp symbols) + :logical-or (logical-or-binary-handler exp symbols) + (binary-exp-handler exp symbols)))) + +(defmethod exp-handler :assignment-exp + [exp symbols] + (let [op (:assignment-operator exp) + var (:val (:left exp)); guaranteed to be a TackyVariable + direct-assignment? (= op :assignment)] + (if direct-assignment? + (let [{dst :val + insts :instructions} (:right exp)] + {:val var + :instructions (flatten [insts + (copy-instruction dst var)])}) + (let [bin-op (assignment-operator->binary-operator op) + bin-exp (p/binary-exp-node (:left exp) (:right exp) bin-op) + {rhs :val + insts :instructions} (exp-handler bin-exp symbols)] + {:val rhs + :instructions (flatten [insts + (copy-instruction rhs var)])})))) + +(defmethod exp-handler :conditional-exp + [exp symbols] + (let [{condition-val :val + condition-insts :instructions} (:left exp) + {then-val :val + then-insts :instructions} (:middle exp) + {else-val :val + else-insts :instructions} (:right exp) + end-label (label "condition_end") + else-label (label "conditional_else") + res (variable "conditional_result") + _ (add-var-to-symbol res (tc/get-type exp) symbols)] + {:val res + :instructions (flatten [condition-insts + (jump-if-zero-instruction condition-val else-label) + then-insts + (copy-instruction then-val res) + (jump-instruction end-label) + (label-instruction else-label) + else-insts + (copy-instruction else-val res) + (label-instruction end-label)])})) + +(defmethod exp-handler :function-call-exp + [{identifier :identifier + arguments :arguments :as exp} symbols] + (let [dst (variable (str "function_call_result_" identifier)) + _ (add-var-to-symbol dst (tc/get-type exp) symbols) + fn-instruction (fun-call-instruction identifier + (mapv #(:val %) arguments) + dst)] + {:val dst + :instructions (flatten [(mapv #(:instructions %) arguments) + fn-instruction])})) + +(defn run-expression-handler + "Transforms a expression to tacky variable and instructions. + + Parameters: + exp: Expression to be parsed + symbols: Atom for symbol map" + [exp symbols] + (postwalk exp #(exp-handler % symbols))) + +;;;; Statement Handlers + +(declare statement->tacky-instruction block-item->tacky-instruction) + +(defn if-statement-handler [s symbols] + (let [cond-exp (run-expression-handler (:condition s) symbols) + cond-value (:val cond-exp) + cond-instructions (:instructions cond-exp) + then-instructions (statement->tacky-instruction (:then-statement s) symbols) + end-label (label "if_end") + else-label (label "if_else") + else? (:else-statement s)] + (if else? + [cond-instructions + (jump-if-zero-instruction cond-value else-label) + then-instructions + (jump-instruction end-label) + (label-instruction else-label) + (statement->tacky-instruction (:else-statement s) symbols) + (label-instruction end-label)] + [cond-instructions + (jump-if-zero-instruction cond-value end-label) + then-instructions + (label-instruction end-label)]))) + +(defn- compound-statement-handler [s symbols] + (flatten (mapv #(block-item->tacky-instruction % symbols) (:block s)))) + +(defn- break-statement-handler [s _] + [(jump-instruction (str "break_" (:label s)))]) + +(defn- continue-statement-handler [s _] + [(jump-instruction (str "continue_" (:label s)))]) + +(defn- while-statement-handler [s symbols] + (let [continue-label (str "continue_" (:label s)) + break-label (str "break_" (:label s)) + cond-exp (run-expression-handler (:condition s) symbols) + cond-value (:val cond-exp) + cond-instructions (:instructions cond-exp) + body-instructions (statement->tacky-instruction (:body s) symbols)] + (flatten [(label-instruction continue-label) + cond-instructions + (jump-if-zero-instruction cond-value break-label) + body-instructions + (jump-instruction continue-label) + (label-instruction break-label)]))) + +(defn- do-while-statement-handler [s symbols] + (let [start-label (label "do_while_start") + continue-label (str "continue_" (:label s)) + break-label (str "break_" (:label s)) + cond-exp (run-expression-handler (:condition s) symbols) + cond-value (:val cond-exp) + cond-instructions (:instructions cond-exp) + body-instructions (statement->tacky-instruction (:body s) symbols)] + (flatten [(label-instruction start-label) + body-instructions + (label-instruction continue-label) + cond-instructions + (jump-if-not-zero-instruction cond-value start-label) + (label-instruction break-label)]))) + +(defn- for-statement-handler [s symbols] + (let [init-instructions (if (= :declaration (:type (:init s))) + (block-item->tacky-instruction (:init s) symbols) + (:instructions (run-expression-handler (:init s) symbols))) + start-label (label "for_start") + break-label (str "break_" (:label s)) + continue-label (str "continue_" (:label s)) + cond? (not (nil? (:condition s))) + body-instructions (statement->tacky-instruction (:body s) symbols) + post-instructions (if (nil? (:post s)) + [] + (:instructions (run-expression-handler (:post s) symbols))) + cond-instructions (if cond? + (let [ce (run-expression-handler (:condition s) symbols) + ce-inst (:instructions ce) + ce-v (:val ce)] + [ce-inst + (jump-if-zero-instruction ce-v break-label)]) + [])] + (flatten + [init-instructions + (label-instruction start-label) + cond-instructions + body-instructions + (label-instruction continue-label) + post-instructions + (jump-instruction start-label) + (label-instruction break-label)]))) + +(defn- statement->tacky-instruction [s symbols] + (condp = (:statement-type s) + :return (let [e (run-expression-handler (:value s) symbols) + val (:val e) + instructions (:instructions e)] + (conj (vec instructions) (return-instruction val))) + :expression [(:instructions (run-expression-handler (:value s) symbols))] + :if (if-statement-handler s symbols) + :compound (compound-statement-handler s symbols) + :break (break-statement-handler s symbols) + :continue (continue-statement-handler s symbols) + :for (for-statement-handler s symbols) + :while (while-statement-handler s symbols) + :do-while (do-while-statement-handler s symbols) + :empty [] + (exc/tacky-error "Invalid statement" s))) + +(defn- declaration->tacky-instruction [d symbols] + (when (:initial d) + (let [local? (nil? (:storage-class d)) + var (parsed-var->tacky-var d) ; only needs :identifier key in declaration + rhs (run-expression-handler (:initial d) symbols)] + (if local? + (flatten [(:instructions rhs) (copy-instruction (:val rhs) var)]) + [])))) ; ignoring initializers for non local variable declarations + +(defn- block-item->tacky-instruction [item symbols] + (condp = (:type item) + :statement (statement->tacky-instruction item symbols) + :declaration (declaration->tacky-instruction item symbols) + (exc/tacky-error "Invalid block item." item))) + +(defn- function-definition->tacky-function [function-definition symbols] + (let [add-return (fn [xs] (conj (vec xs) (return-instruction (constant {:type :int :value 0})))) + instructions (->> function-definition + :body + (remove nil?) + (mapv #(block-item->tacky-instruction % symbols)) + flatten + (remove nil?) + add-return)] + (-> function-definition + (dissoc :body) + (assoc :global? (get-in @symbols [(:identifier function-definition) + :attribute + :global?])) + (assoc :instructions instructions)))) + +(defn- tacky-static-variable [identifier global? variable-type initial] + {:identifier identifier + :global? global? + :initial initial + :type :declaration + :variable-type variable-type + :declaration-type :static-variable}) + +(defn- tacky-static-variable-instructions + "Generates list of tacky static variable from symbol map." + [ident->symbol] + (let [rf (fn [acc [k v]] + (if (= :static (get-in v [:attribute :type])) + (let [vtype (get-in v [:type]) + global? (get-in v [:attribute :global?]) + initial (get-in v [:attribute :initial-value]) + tentative-initial (if (= :int (:type vtype)) + (sym/initial-iv (sym/int-init 0)) + (sym/initial-iv (sym/long-init 0))) + itype (get-in v [:attribute :initial-value :type])] + (condp = itype + :initial (conj acc (tacky-static-variable k global? vtype initial)) + :tentative (conj acc (tacky-static-variable k global? vtype tentative-initial)) + acc)) + acc))] + (reduce rf [] ident->symbol))) + +(defn- tacky-function-instructions [ast symbols] + (let [fn-defined? (fn [x] (if (= :function (:declaration-type x)) + (or (= (:identifier x) "main") (seq (:body x))) + true))] + (->> ast + (filterv #(= :function (:declaration-type %))) + (filterv fn-defined?) + (mapv #(function-definition->tacky-function % symbols))))) + +(defn tacky-generate [{ast :program ident->symbol :ident->symbol}] + (let [variable-instructions (tacky-static-variable-instructions ident->symbol) + symbols (atom ident->symbol) + function-instructions (tacky-function-instructions ast symbols) + program (vec (concat variable-instructions function-instructions)) + ;_ (m/coerce s/TackyProgram program) + ;_ (m/coerce s/SymbolMap @symbols) + ] + {:program program + :ident->symbol @symbols})) + +(defn tacky-from-src [src] + (-> src + l/lex + p/parse + a/validate + tacky-generate)) + +(comment + + (def tmp + " +long foo(void) { + return 1; +} + +int bar(int x, int y) { + return x + y; +} + +int main(void) { +int x = 6; +return (long) foo() + 2 + x + bar(x, 7) + (3 ? 4 : 5); + +}") + + (-> tmp + l/lex + p/parse + a/validate) + + (tacky-from-src tmp) + + ()) + +(comment + + (def ex " +long foo(void) { + return 1; +} + +int bar(int x, int y) { + return x + y; +} + +int main(void) { +int x = 6; +return (long) foo() + 2 + x + bar(x, 7) + (3 ? 4 : 5); +}") + + (-> ex + l/lex + p/parse + a/validate) + + (tacky-from-src + "int main(void) { return 42; }") + + (tacky-from-src + " +extern int foo; + +int foo; + +int foo; + +int main(void) { + double x = 1000; + + for (int i = 0; i < 5; i = i + 1) + foo = foo + 1; + return foo; +} + +int foo; + +") + + (def file-path "./test-programs/example.c") + + (slurp "./test-programs/example.c") + + (-> file-path + slurp + p/parse-from-src + a/validate) + + (-> file-path + slurp + p/parse-from-src + a/validate + tacky-generate) + + (pretty/explain + s/TackyProgram + (-> file-path + slurp + p/parse-from-src + a/validate + tacky-generate + :program)) + + (def x (-> file-path + slurp + p/parse-from-src + a/validate)) + + (pretty/explain + s/SymbolMap + (:ident->symbol (tacky-generate x))) + + (pretty/explain + s/SymbolMap + (-> file-path + slurp + p/parse-from-src + a/validate + tacky-generate + :ident->symbol)) + + (-> file-path + slurp + p/parse-from-src + a/validate + tacky-generate) + + ()) |