(;module:
lux
(lux (control [monad #+ do])
[meta "meta/" Monad])
(luxc [";L" host]
(lang ["ls" synthesis])
(generator (host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))))
[../runtime])
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
(def: (pop-altI stack-depth)
(-> Nat $;Inst)
(case stack-depth
+0 id
+1 $i;POP
+2 $i;POP2
_ ## (n.> +2)
(|>. $i;POP2
(pop-altI (n.- +2 stack-depth)))))
(def: peekI
$;Inst
(|>. $i;DUP
($i;INVOKESTATIC hostL;runtime-class
"pm_peek"
($t;method (list ../runtime;$Stack)
(#;Some $Object)
(list))
false)))
(def: popI
$;Inst
(|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_pop"
($t;method (list ../runtime;$Stack)
(#;Some ../runtime;$Stack)
(list))
false)))
(def: pushI
$;Inst
(|>. ($i;INVOKESTATIC hostL;runtime-class
"pm_push"
($t;method (list ../runtime;$Stack $Object)
(#;Some ../runtime;$Stack)
(list))
false)))
(def: (generate-pattern' generate stack-depth @else @end path)
(-> (-> ls;Synthesis (Meta $;Inst))
Nat $;Label $;Label ls;Path (Meta $;Inst))
(case path
(#ls;ExecP bodyS)
(do meta;Monad
[bodyI (generate bodyS)]
(wrap (|>. (pop-altI stack-depth)
bodyI
($i;GOTO @end))))
#ls;UnitP
(meta/wrap popI)
(#ls;BindP register)
(meta/wrap (|>. peekI
($i;ASTORE register)
popI))
(#ls;BoolP value)
(meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)]
(|>. peekI
($i;unwrap #$;Boolean)
(jumpI @else))))
(^template [ ]
( value)
(meta/wrap (|>. peekI
($i;unwrap #$;Long)
($i;long (|> value ))
$i;LCMP
($i;IFNE @else))))
([#ls;NatP (:! Int)]
[#ls;IntP (: Int)]
[#ls;DegP (:! Int)])
(#ls;FracP value)
(meta/wrap (|>. peekI
($i;unwrap #$;Double)
($i;double value)
$i;DCMPL
($i;IFNE @else)))
(#ls;TextP value)
(meta/wrap (|>. peekI
($i;string value)
($i;INVOKEVIRTUAL "java.lang.Object"
"equals"
($t;method (list $Object)
(#;Some $t;boolean)
(list))
false)
($i;IFEQ @else)))
(#ls;TupleP idx subP)
(do meta;Monad
[subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx tail?] (case idx
(#;Left idx)
[idx false]
(#;Right idx)
[idx true])]]
(wrap (case idx
+0
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int 0)
$i;AALOAD
pushI
subI)
_
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Tuple))
($i;int (nat-to-int idx))
($i;INVOKESTATIC hostL;runtime-class
(if tail? "pm_right" "pm_left")
($t;method (list ../runtime;$Tuple $t;int)
(#;Some $Object)
(list))
false)
pushI
subI))))
(#ls;VariantP idx subP)
(do meta;Monad
[subI (generate-pattern' generate stack-depth @else @end subP)
#let [[idx last?] (case idx
(#;Left idx)
[idx false]
(#;Right idx)
[idx true])
flagI (if last?
($i;string "")
$i;NULL)]]
(wrap (<| $i;with-label (function [@success])
$i;with-label (function [@fail])
(|>. peekI
($i;CHECKCAST ($t;descriptor ../runtime;$Variant))
($i;int (nat-to-int idx))
flagI
($i;INVOKESTATIC hostL;runtime-class "pm_variant"
($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag)
(#;Some ../runtime;$Datum)
(list))
false)
$i;DUP
($i;IFNULL @fail)
($i;GOTO @success)
($i;label @fail)
$i;POP
($i;GOTO @else)
($i;label @success)
pushI
subI))))
(#ls;SeqP leftP rightP)
(do meta;Monad
[leftI (generate-pattern' generate stack-depth @else @end leftP)
rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. leftI
rightI)))
(#ls;AltP leftP rightP)
(do meta;Monad
[@alt-else $i;make-label
leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP)
rightI (generate-pattern' generate stack-depth @else @end rightP)]
(wrap (|>. $i;DUP
leftI
($i;label @alt-else)
$i;POP
rightI)))
))
(def: (generate-pattern generate path @end)
(-> (-> ls;Synthesis (Meta $;Inst))
ls;Path $;Label (Meta $;Inst))
(do meta;Monad
[@else $i;make-label
pathI (generate-pattern' generate +1 @else @end path)]
(wrap (|>. pathI
($i;label @else)
$i;POP
($i;INVOKESTATIC hostL;runtime-class
"pm_fail"
($t;method (list) #;None (list))
false)
$i;NULL
($i;GOTO @end)))))
(def: #export (generate-case generate valueS path)
(-> (-> ls;Synthesis (Meta $;Inst))
ls;Synthesis ls;Path (Meta $;Inst))
(do meta;Monad
[@end $i;make-label
valueI (generate valueS)
pathI (generate-pattern generate path @end)]
(wrap (|>. valueI
$i;NULL
$i;SWAP
pushI
pathI
($i;label @end)))))
(def: #export (generate-let generate register inputS exprS)
(-> (-> ls;Synthesis (Meta $;Inst))
Nat ls;Synthesis ls;Synthesis (Meta $;Inst))
(do meta;Monad
[inputI (generate inputS)
exprI (generate exprS)]
(wrap (|>. inputI
($i;ASTORE register)
exprI))))