aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/host/jvm/inst.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/generator/host/jvm/inst.lux')
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux383
1 files changed, 0 insertions, 383 deletions
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
deleted file mode 100644
index 37ab75020..000000000
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ /dev/null
@@ -1,383 +0,0 @@
-(;module:
- [lux #- char]
- (lux (control monad
- ["p" parser])
- (data [maybe]
- ["e" error]
- text/format
- (coll [list "L/" Functor<List>]))
- [host #+ do-to]
- [meta]
- (meta [code]
- ["s" syntax #+ syntax:]))
- ["$" ..]
- (.. ["$t" type]))
-
-## [Host]
-(host;import #long java.lang.Object)
-(host;import #long java.lang.String)
-
-(syntax: (declare [codes (p;many s;local-symbol)])
- (|> codes
- (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int)))))
- wrap))
-
-(`` (host;import org.objectweb.asm.Opcodes
- (#static NOP int)
-
- ## Conversion
- (~~ (declare D2F D2I D2L
- F2D F2I F2L
- I2B I2C I2D I2F I2L I2S
- L2D L2F L2I))
-
- ## Primitive
- (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
- T_BYTE T_SHORT T_INT T_LONG))
-
- ## Class
- (~~ (declare CHECKCAST NEW INSTANCEOF))
-
- ## Stack
- (~~ (declare DUP DUP_X1 DUP_X2
- DUP2 DUP2_X1 DUP2_X2
- POP POP2
- SWAP))
-
- ## Jump
- (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL
- IFEQ IFNE IFLT IFLE IFGT IFGE
- GOTO))
-
- (#static ACONST_NULL int)
-
- ## Var
- (~~ (declare ILOAD LLOAD DLOAD ALOAD
- ISTORE LSTORE ASTORE))
-
- ## Arithmetic
- (~~ (declare IADD ISUB IMUL IDIV IREM
- LADD LSUB LMUL LDIV LREM LCMP
- FADD FSUB FMUL FDIV FREM FCMPG FCMPL
- DADD DSUB DMUL DDIV DREM DCMPG DCMPL))
-
- ## Bit-wise
- (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR
- LAND LOR LXOR LSHL LSHR LUSHR))
-
- ## Array
- (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY
- AALOAD AASTORE
- BALOAD BASTORE
- SALOAD SASTORE
- IALOAD IASTORE
- LALOAD LASTORE
- FALOAD FASTORE
- DALOAD DASTORE
- CALOAD CASTORE))
-
- ## Member
- (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
- INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE))
-
- (#static ATHROW int)
-
- ## Concurrency
- (~~ (declare MONITORENTER MONITOREXIT))
-
- ## Return
- (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
- ))
-
-(host;import org.objectweb.asm.FieldVisitor
- (visitEnd [] void))
-
-(host;import org.objectweb.asm.Label
- (new []))
-
-(host;import org.objectweb.asm.MethodVisitor
- (visitCode [] void)
- (visitMaxs [int int] void)
- (visitEnd [] void)
- (visitInsn [int] void)
- (visitLdcInsn [Object] void)
- (visitFieldInsn [int String String String] void)
- (visitTypeInsn [int String] void)
- (visitVarInsn [int int] void)
- (visitIntInsn [int int] void)
- (visitMethodInsn [int String String String boolean] void)
- (visitLabel [Label] void)
- (visitJumpInsn [int Label] void)
- (visitTryCatchBlock [Label Label Label String] void)
- (visitTableSwitchInsn [int int Label (Array Label)] void)
- )
-
-## [Insts]
-(def: #export make-label
- (Meta Label)
- (function [compiler]
- (#e;Success [compiler (Label.new [])])))
-
-(def: #export (with-label action)
- (-> (-> Label $;Inst) $;Inst)
- (action (Label.new [])))
-
-(do-template [<name> <type> <prepare>]
- [(def: #export (<name> value)
- (-> <type> $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitLdcInsn [(<prepare> value)]))))]
-
- [boolean Bool id]
- [int Int host;l2i]
- [long Int id]
- [double Frac id]
- [char Nat (|>. nat-to-int host;l2i host;i2c)]
- [string Text id]
- )
-
-(syntax: (prefix [base s;local-symbol])
- (wrap (list (code;local-symbol (format "Opcodes." base)))))
-
-(def: #export NULL
- $;Inst
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitInsn [(prefix ACONST_NULL)]))))
-
-(do-template [<name>]
- [(def: #export <name>
- $;Inst
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitInsn [(prefix <name>)]))))]
-
- [NOP]
-
- ## Stack
- [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2]
- [POP] [POP2]
- [SWAP]
-
- ## Conversions
- [D2F] [D2I] [D2L]
- [F2D] [F2I] [F2L]
- [I2B] [I2C] [I2D] [I2F] [I2L] [I2S]
- [L2D] [L2F] [L2I]
-
- ## Integer arithmetic
- [IADD] [ISUB] [IMUL] [IDIV] [IREM]
-
- ## Integer bitwise
- [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
-
- ## Long arithmetic
- [LADD] [LSUB] [LMUL] [LDIV] [LREM]
- [LCMP]
-
- ## Long bitwise
- [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
-
- ## Float arithmetic
- [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL]
-
- ## Double arithmetic
- [DADD] [DSUB] [DMUL] [DDIV] [DREM]
- [DCMPG] [DCMPL]
-
- ## Array
- [ARRAYLENGTH]
- [AALOAD] [AASTORE]
- [BALOAD] [BASTORE]
- [SALOAD] [SASTORE]
- [IALOAD] [IASTORE]
- [LALOAD] [LASTORE]
- [FALOAD] [FASTORE]
- [DALOAD] [DASTORE]
- [CALOAD] [CASTORE]
-
- ## Exceptions
- [ATHROW]
-
- ## Concurrency
- [MONITORENTER] [MONITOREXIT]
-
- ## Return
- [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN]
- )
-
-(do-template [<name>]
- [(def: #export (<name> register)
- (-> Nat $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))]
-
- [ILOAD] [LLOAD] [DLOAD] [ALOAD]
- [ISTORE] [LSTORE] [ASTORE]
- )
-
-(do-template [<name> <inst>]
- [(def: #export (<name> class field type)
- (-> Text Text $;Type $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]
-
- [GETSTATIC Opcodes.GETSTATIC]
- [PUTSTATIC Opcodes.PUTSTATIC]
-
- [PUTFIELD Opcodes.PUTFIELD]
- [GETFIELD Opcodes.GETFIELD]
- )
-
-(do-template [<name> <inst>]
- [(def: #export (<name> class)
- (-> Text $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
-
- [CHECKCAST Opcodes.CHECKCAST]
- [NEW Opcodes.NEW]
- [INSTANCEOF Opcodes.INSTANCEOF]
- [ANEWARRAY Opcodes.ANEWARRAY]
- )
-
-(def: #export (NEWARRAY type)
- (-> $;Primitive $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
- #$;Boolean Opcodes.T_BOOLEAN
- #$;Byte Opcodes.T_BYTE
- #$;Short Opcodes.T_SHORT
- #$;Int Opcodes.T_INT
- #$;Long Opcodes.T_LONG
- #$;Float Opcodes.T_FLOAT
- #$;Double Opcodes.T_DOUBLE
- #$;Char Opcodes.T_CHAR)]))))
-
-(do-template [<name> <inst>]
- [(def: #export (<name> class method-name method-signature interface?)
- (-> Text Text $;Method Bool $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]
-
- [INVOKESTATIC Opcodes.INVOKESTATIC]
- [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
- [INVOKESPECIAL Opcodes.INVOKESPECIAL]
- [INVOKEINTERFACE Opcodes.INVOKEINTERFACE]
- )
-
-(do-template [<name>]
- [(def: #export (<name> @where)
- (-> $;Label $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))]
-
- [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL]
- [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE]
- [GOTO]
- )
-
-(def: #export (TABLESWITCH min max default labels)
- (-> Int Int $;Label (List $;Label) $;Inst)
- (function [visitor]
- (let [num-labels (list;size labels)
- labels-array (host;array Label num-labels)
- _ (loop [idx +0]
- (if (n.< num-labels idx)
- (exec (host;array-write idx
- (maybe;assume (list;nth idx labels))
- labels-array)
- (recur (n.inc idx)))
- []))]
- (do-to visitor
- (MethodVisitor.visitTableSwitchInsn [min max default labels-array])))))
-
-(def: #export (try @from @to @handler exception)
- (-> $;Label $;Label $;Label Text $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitTryCatchBlock [@from @to @handler ($t;binary-name exception)]))))
-
-(def: #export (label @label)
- (-> $;Label $;Inst)
- (function [visitor]
- (do-to visitor
- (MethodVisitor.visitLabel [@label]))))
-
-(def: #export (array type)
- (-> $;Type $;Inst)
- (case type
- (#$;Primitive prim)
- (NEWARRAY prim)
-
- (#$;Generic generic)
- (let [elem-class (case generic
- (#$;Class class params)
- ($t;binary-name class)
-
- _
- ($t;binary-name "java.lang.Object"))]
- (ANEWARRAY elem-class))
-
- _
- (ANEWARRAY ($t;descriptor type))))
-
-(def: (primitive-wrapper type)
- (-> $;Primitive Text)
- (case type
- #$;Boolean "java.lang.Boolean"
- #$;Byte "java.lang.Byte"
- #$;Short "java.lang.Short"
- #$;Int "java.lang.Integer"
- #$;Long "java.lang.Long"
- #$;Float "java.lang.Float"
- #$;Double "java.lang.Double"
- #$;Char "java.lang.Character"))
-
-(def: (primitive-unwrap type)
- (-> $;Primitive Text)
- (case type
- #$;Boolean "booleanValue"
- #$;Byte "byteValue"
- #$;Short "shortValue"
- #$;Int "intValue"
- #$;Long "longValue"
- #$;Float "floatValue"
- #$;Double "doubleValue"
- #$;Char "charValue"))
-
-(def: #export (wrap type)
- (-> $;Primitive $;Inst)
- (let [class (primitive-wrapper type)]
- (|>. (INVOKESTATIC class "valueOf"
- ($t;method (list (#$;Primitive type))
- (#;Some ($t;class class (list)))
- (list))
- false))))
-
-(def: #export (unwrap type)
- (-> $;Primitive $;Inst)
- (let [class (primitive-wrapper type)]
- (|>. (CHECKCAST class)
- (INVOKEVIRTUAL class (primitive-unwrap type)
- ($t;method (list) (#;Some (#$;Primitive type)) (list))
- false))))
-
-(def: #export (fuse insts)
- (-> (List $;Inst) $;Inst)
- (case insts
- #;Nil
- id
-
- (#;Cons singleton #;Nil)
- singleton
-
- (#;Cons head tail)
- (. (fuse tail) head)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 00:22:00 +0000