From 196c1843d1a4a32ab92b9ba5c549933a5ce30c17 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Aug 2018 19:06:17 -0400 Subject: Fixes for pattern-matching/case synthesis & translation. --- .../source/luxc/lang/translation/jvm/case.jvm.lux | 96 +++++++++++----------- .../luxc/lang/translation/jvm/runtime.jvm.lux | 59 +------------ 2 files changed, 49 insertions(+), 106 deletions(-) (limited to 'new-luxc/source/luxc/lang/translation/jvm') diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index e11187787..ac7ab3b83 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -57,9 +57,8 @@ (list)) #0))) -(def: (path' translate stack-depth @else @end path) - (-> (-> Synthesis (Operation Inst)) - Nat Label Label Path (Operation Inst)) +(def: (path' phase stack-depth @else @end path) + (-> Phase Nat Label Label Path (Operation Inst)) (.case path #synthesis.Pop (operation/wrap popI) @@ -101,15 +100,39 @@ (#synthesis.Then bodyS) (do phase.Monad - [bodyI (translate bodyS)] + [bodyI (phase bodyS)] (wrap (|>> (pop-altI stack-depth) bodyI (_.GOTO @end)))) - (^template [ ] + (^template [ ] (^ ( idx)) - (operation/wrap (.case 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 .id] + [synthesis.side/right (_.string "") .inc]) + + (^template [ ] + (^ ( idx)) + (operation/wrap (.case ( idx) 0 (|>> peekI (_.CHECKCAST ($t.descriptor runtime.$Tuple)) @@ -128,39 +151,14 @@ (list)) #0) pushI)))) - ([synthesis.member/left "pm_left"] - [synthesis.member/right "pm_right"]) - - (^template [ ] - (^ ( idx)) - (.let [idx ( 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 .id] - [synthesis.side/right (_.string "") .inc]) + ([synthesis.member/left "pm_left" id] + [synthesis.member/right "pm_right" inc]) (#synthesis.Alt leftP rightP) (do phase.Monad [@alt-else _.make-label - leftI (path' translate (inc stack-depth) @alt-else @end leftP) - rightI (path' translate stack-depth @else @end rightP)] + leftI (path' phase (inc stack-depth) @alt-else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] (wrap (|>> _.DUP leftI (_.label @alt-else) @@ -169,17 +167,17 @@ (#synthesis.Seq leftP rightP) (do phase.Monad - [leftI (path' translate stack-depth @else @end leftP) - rightI (path' translate stack-depth @else @end rightP)] + [leftI (path' phase stack-depth @else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] (wrap (|>> leftI rightI))) )) -(def: (path translate path @end) +(def: (path phase path @end) (-> Phase Path Label (Operation Inst)) (do phase.Monad [@else _.make-label - pathI (..path' translate 1 @else @end path)] + pathI (..path' phase 1 @else @end path)] (wrap (|>> pathI (_.label @else) _.POP @@ -190,12 +188,12 @@ _.NULL (_.GOTO @end))))) -(def: #export (if translate testS thenS elseS) +(def: #export (if phase testS thenS elseS) (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) (do phase.Monad - [testI (translate testS) - thenI (translate thenS) - elseI (translate elseS)] + [testI (phase testS) + thenI (phase thenS) + elseI (phase elseS)] (wrap (<| _.with-label (function (_ @else)) _.with-label (function (_ @end)) (|>> testI @@ -207,21 +205,21 @@ elseI (_.label @end)))))) -(def: #export (let translate inputS register exprS) +(def: #export (let phase inputS register exprS) (-> Phase Synthesis Nat Synthesis (Operation Inst)) (do phase.Monad - [inputI (translate inputS) - exprI (translate exprS)] + [inputI (phase inputS) + exprI (phase exprS)] (wrap (|>> inputI (_.ASTORE register) exprI)))) -(def: #export (case translate valueS path) +(def: #export (case phase valueS path) (-> Phase Synthesis Path (Operation Inst)) (do phase.Monad [@end _.make-label - valueI (translate valueS) - pathI (..path translate path @end)] + valueI (phase valueS) + pathI (..path phase path @end)] (wrap (|>> _.NULL valueI pushI diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index c92ab1026..20c31bd5d 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -106,59 +106,8 @@ Def (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE) store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) - store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE) - force-textMT ($t.method (list $Object) (#.Some $String) (list))] - (|>> ($d.method #$.Public $.staticM "force_text" force-textMT - (<| _.with-label (function (_ @is-null)) - _.with-label (function (_ @normal-object)) - _.with-label (function (_ @array-loop)) - _.with-label (function (_ @within-bounds)) - _.with-label (function (_ @is-first)) - _.with-label (function (_ @elem-end)) - _.with-label (function (_ @fold-end)) - (let [on-normal-objectI (|>> (_.ALOAD 0) - (_.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) #0)) - on-null-objectI (_.string "NULL") - arrayI (|>> (_.ALOAD 0) - (_.CHECKCAST ($t.descriptor $Object-Array))) - recurseI (_.INVOKESTATIC //.runtime-class "force_text" force-textMT #0) - force-elemI (|>> _.DUP arrayI _.SWAP _.AALOAD recurseI) - swap2 (|>> _.DUP2_X2 ## X,Y => Y,X,Y - _.POP2 ## Y,X,Y => Y,X - ) - add-spacingI (|>> (_.string ", ") _.SWAP string-concatI) - merge-with-totalI (|>> _.DUP_X2 _.POP ## TSIP => TPSI - swap2 ## TPSI => SITP - string-concatI ## SITP => SIT - _.DUP_X2 _.POP ## SIT => TSI - ) - foldI (|>> _.DUP ## TSI => TSII - (_.IFEQ @is-first) ## TSI - force-elemI add-spacingI merge-with-totalI (_.GOTO @elem-end) - (_.label @is-first) ## TSI - force-elemI merge-with-totalI - (_.label @elem-end) ## TSI - ) - inc-idxI (|>> (_.int +1) _.IADD) - on-array-objectI (|>> (_.string "[") ## T - arrayI _.ARRAYLENGTH ## TS - (_.int +0) ## TSI - (_.label @array-loop) ## TSI - _.DUP2 - (_.IF_ICMPGT @within-bounds) ## TSI - _.POP2 (_.string "]") string-concatI (_.GOTO @fold-end) - (_.label @within-bounds) - foldI inc-idxI (_.GOTO @array-loop) - (_.label @fold-end))]) - (|>> (_.ALOAD 0) - (_.IFNULL @is-null) - (_.ALOAD 0) - (_.INSTANCEOF ($t.descriptor $Object-Array)) - (_.IFEQ @normal-object) - on-array-objectI _.ARETURN - (_.label @normal-object) on-normal-objectI _.ARETURN - (_.label @is-null) on-null-objectI _.ARETURN))) - ($d.method #$.Public $.staticM "variant_make" + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" ($t.method (list $t.int $Object $Object) (#.Some $Variant) (list)) @@ -169,10 +118,6 @@ store-valueI _.ARETURN))))) -(def: #export force-textI - Inst - (_.INVOKESTATIC //.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0)) - (def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0))) (def: frac-methods -- cgit v1.2.3