From 697707d8560a5735be38fd9b1ff91a02c289d48f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 16 Apr 2019 20:53:41 -0400 Subject: Made some new-luxc modules "old". --- new-luxc/source/luxc/lang/translation/jvm/case.lux | 235 +++++++++++++++++++++ 1 file changed, 235 insertions(+) create mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.lux (limited to 'new-luxc/source/luxc/lang/translation/jvm/case.lux') diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.lux b/new-luxc/source/luxc/lang/translation/jvm/case.lux new file mode 100644 index 000000000..43d11c71e --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/case.lux @@ -0,0 +1,235 @@ +(.module: + [lux (#- if let case) + [abstract + [monad (#+ do)]] + [control + ["." function] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + [tool + [compiler + ["." synthesis (#+ Path Synthesis)] + ["." phase ("operation/." monad)]]]] + [luxc + [lang + [host + ["$" jvm (#+ Label Inst Operation Phase) + ["$t" type] + ["_" inst]]]]] + ["." // (#+ $Object) + ["." runtime]]) + +(def: (pop-altI stack-depth) + (-> Nat Inst) + (.case stack-depth + 0 function.identity + 1 _.POP + 2 _.POP2 + _ ## (n/> 2) + (|>> _.POP2 + (pop-altI (n/- 2 stack-depth))))) + +(def: peekI + Inst + (|>> _.DUP + (_.INVOKESTATIC //.runtime-class + "pm_peek" + ($t.method (list runtime.$Stack) + (#.Some $Object) + (list)) + #0))) + +(def: popI + Inst + (|>> (_.INVOKESTATIC //.runtime-class + "pm_pop" + ($t.method (list runtime.$Stack) + (#.Some runtime.$Stack) + (list)) + #0))) + +(def: pushI + Inst + (|>> (_.INVOKESTATIC //.runtime-class + "pm_push" + ($t.method (list runtime.$Stack $Object) + (#.Some runtime.$Stack) + (list)) + #0))) + +(def: (path' phase stack-depth @else @end path) + (-> Phase Nat Label Label Path (Operation Inst)) + (.case path + #synthesis.Pop + (operation/wrap popI) + + (#synthesis.Bind register) + (operation/wrap (|>> peekI + (_.ASTORE register))) + + (^ (synthesis.path/bit value)) + (operation/wrap (.let [jumpI (.if value _.IFEQ _.IFNE)] + (|>> peekI + (_.unwrap #$.Boolean) + (jumpI @else)))) + + (^ (synthesis.path/i64 value)) + (operation/wrap (|>> peekI + (_.unwrap #$.Long) + (_.long (.int value)) + _.LCMP + (_.IFNE @else))) + + (^ (synthesis.path/f64 value)) + (operation/wrap (|>> peekI + (_.unwrap #$.Double) + (_.double value) + _.DCMPL + (_.IFNE @else))) + + (^ (synthesis.path/text value)) + (operation/wrap (|>> peekI + (_.string value) + (_.INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t.method (list $Object) + (#.Some $t.boolean) + (list)) + #0) + (_.IFEQ @else))) + + (#synthesis.Then bodyS) + (do phase.monad + [bodyI (phase bodyS)] + (wrap (|>> (pop-altI stack-depth) + bodyI + (_.GOTO @end)))) + + + (^template [ ] + (^ ( idx)) + (operation/wrap (<| _.with-label (function (_ @success)) + _.with-label (function (_ @fail)) + (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Variant)) + (_.int (.int ( idx))) + + (_.INVOKESTATIC //.runtime-class "pm_variant" + ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) + (#.Some runtime.$Datum) + (list)) + #0) + _.DUP + (_.IFNULL @fail) + (_.GOTO @success) + (_.label @fail) + _.POP + (_.GOTO @else) + (_.label @success) + pushI)))) + ([synthesis.side/left _.NULL function.identity] + [synthesis.side/right (_.string "") .inc]) + + (^ (synthesis.member/left lefts)) + (operation/wrap (.let [accessI (.case lefts + 0 + _.AALOAD + + lefts + (_.INVOKESTATIC //.runtime-class + "tuple_left" + ($t.method (list runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + #0))] + (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Tuple)) + (_.int (.int lefts)) + accessI + pushI))) + + (^ (synthesis.member/right lefts)) + (operation/wrap (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Tuple)) + (_.int (.int lefts)) + (_.INVOKESTATIC //.runtime-class + "tuple_right" + ($t.method (list runtime.$Tuple $t.int) + (#.Some $Object) + (list)) + #0) + pushI)) + + (#synthesis.Alt leftP rightP) + (do phase.monad + [@alt-else _.make-label + leftI (path' phase (inc stack-depth) @alt-else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] + (wrap (|>> _.DUP + leftI + (_.label @alt-else) + _.POP + rightI))) + + (#synthesis.Seq leftP rightP) + (do phase.monad + [leftI (path' phase stack-depth @else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] + (wrap (|>> leftI + rightI))) + )) + +(def: (path phase path @end) + (-> Phase Path Label (Operation Inst)) + (do phase.monad + [@else _.make-label + pathI (..path' phase 1 @else @end path)] + (wrap (|>> pathI + (_.label @else) + _.POP + (_.INVOKESTATIC //.runtime-class + "pm_fail" + ($t.method (list) #.None (list)) + #0) + _.NULL + (_.GOTO @end))))) + +(def: #export (if phase testS thenS elseS) + (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) + (do phase.monad + [testI (phase testS) + thenI (phase thenS) + elseI (phase elseS)] + (wrap (<| _.with-label (function (_ @else)) + _.with-label (function (_ @end)) + (|>> testI + (_.unwrap #$.Boolean) + (_.IFEQ @else) + thenI + (_.GOTO @end) + (_.label @else) + elseI + (_.label @end)))))) + +(def: #export (let phase inputS register exprS) + (-> Phase Synthesis Nat Synthesis (Operation Inst)) + (do phase.monad + [inputI (phase inputS) + exprI (phase exprS)] + (wrap (|>> inputI + (_.ASTORE register) + exprI)))) + +(def: #export (case phase valueS path) + (-> Phase Synthesis Path (Operation Inst)) + (do phase.monad + [@end _.make-label + valueI (phase valueS) + pathI (..path phase path @end)] + (wrap (|>> _.NULL + valueI + pushI + pathI + (_.label @end))))) -- cgit v1.2.3