From 296d087530cb142efec1dea159770346bb43c3c0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Nov 2017 19:51:33 -0400 Subject: - Heavy refactoring. --- new-luxc/source/luxc/host/jvm/inst.lux | 383 --------------------------------- 1 file changed, 383 deletions(-) delete mode 100644 new-luxc/source/luxc/host/jvm/inst.lux (limited to 'new-luxc/source/luxc/host/jvm/inst.lux') diff --git a/new-luxc/source/luxc/host/jvm/inst.lux b/new-luxc/source/luxc/host/jvm/inst.lux deleted file mode 100644 index 37ab75020..000000000 --- a/new-luxc/source/luxc/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])) - [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 [ ] - [(def: #export ( value) - (-> $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitLdcInsn [( 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 [] - [(def: #export - $;Inst - (function [visitor] - (do-to visitor - (MethodVisitor.visitInsn [(prefix )]))))] - - [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 [] - [(def: #export ( register) - (-> Nat $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitVarInsn [(prefix ) (nat-to-int register)]))))] - - [ILOAD] [LLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] [ASTORE] - ) - -(do-template [ ] - [(def: #export ( class field type) - (-> Text Text $;Type $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitFieldInsn [ ($t;binary-name class) field ($t;descriptor type)]))))] - - [GETSTATIC Opcodes.GETSTATIC] - [PUTSTATIC Opcodes.PUTSTATIC] - - [PUTFIELD Opcodes.PUTFIELD] - [GETFIELD Opcodes.GETFIELD] - ) - -(do-template [ ] - [(def: #export ( class) - (-> Text $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitTypeInsn [ ($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 [ ] - [(def: #export ( class method-name method-signature interface?) - (-> Text Text $;Method Bool $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitMethodInsn [ ($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 [] - [(def: #export ( @where) - (-> $;Label $;Inst) - (function [visitor] - (do-to visitor - (MethodVisitor.visitJumpInsn [(prefix ) @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))) -- cgit v1.2.3