From a79927892174c3564c83a0e741e5cc0aaaeeb37c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 30 Jun 2017 18:43:07 -0400 Subject: - WIP: Added generation for common procedures. --- new-luxc/source/luxc/generator/host/jvm.lux | 85 +++++++++++-- new-luxc/source/luxc/generator/host/jvm/def.lux | 146 ++++++++++++++++++++-- new-luxc/source/luxc/generator/host/jvm/inst.lux | 151 +++++++++++++++++++++-- 3 files changed, 351 insertions(+), 31 deletions(-) (limited to 'new-luxc/source/luxc/generator/host') diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux index f1eb61166..d67b6ef91 100644 --- a/new-luxc/source/luxc/generator/host/jvm.lux +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -1,12 +1,21 @@ (;module: [lux #- Type Def] - (lux [host #+ jvm-import])) + (lux (control monad + ["p" parser]) + (data (coll [list "L/" Functor])) + [macro] + (macro [code] + ["s" syntax #+ syntax:]) + [host #+ jvm-import])) ## [Host] (jvm-import org.objectweb.asm.MethodVisitor) (jvm-import org.objectweb.asm.ClassWriter) +(jvm-import #long org.objectweb.asm.Label + (new [])) + ## [Type] (type: #export Bound #Upper @@ -27,6 +36,12 @@ (#Wildcard (Maybe [Bound Generic])) (#Class Text (List Generic))) +(type: #export Class + [Text (List Generic)]) + +(type: #export Parameter + [Text Class (List Class)]) + (type: #export #rec Type (#Primitive Primitive) (#Generic Generic) @@ -43,19 +58,69 @@ (type: #export Inst (-> MethodVisitor MethodVisitor)) +(type: #export Label + org.objectweb.asm.Label) + +(type: #export Register Nat) + (type: #export Visibility #Public #Protected #Private #Default) -(type: #export Method-Config - {#staticM Bool - #finalM Bool - #synchronizedM Bool}) +(type: #export Version + #V1.1 + #V1.2 + #V1.3 + #V1.4 + #V1.5 + #V1.6 + #V1.7 + #V1.8) + +## [Values] +(syntax: (config: [type s;local-symbol] + [none s;local-symbol] + [++ s;local-symbol] + [options (s;tuple (p;many s;local-symbol))]) + (let [g!type (code;local-symbol type) + g!none (code;local-symbol none) + g!tags+ (L/map code;local-tag options) + g!_left (code;local-symbol "_left") + g!_right (code;local-symbol "_right") + g!options+ (L/map (function [option] + (` (def: (~' #export) (~ (code;local-symbol option)) + (~ g!type) + (|> (~ g!none) + (set@ (~ (code;local-tag option)) true))))) + options)] + (wrap (list& (` (type: (~' #export) (~ g!type) + (~ (code;record (L/map (function [tag] + [tag (` ;Bool)]) + g!tags+))))) + + (` (def: (~' #export) (~ g!none) + (~ g!type) + (~ (code;record (L/map (function [tag] + [tag (` false)]) + g!tags+))))) + + (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) + (-> (~ g!type) (~ g!type) (~ g!type)) + (~ (code;record (L/map (function [tag] + [tag (` (and (get@ (~ tag) (~ g!_left)) + (get@ (~ tag) (~ g!_right))))]) + g!tags+))))) + + g!options+)))) + +## Configs +(config: Class-Config noneC ++C [finalC]) +(config: Method-Config noneM ++M [staticM finalM synchronizedM]) +(config: Field-Config noneF ++F [staticF finalF transientF volatileF]) -(type: #export Field-Config - {#staticF Bool - #finalF Bool - #transientF Bool - #volatileF Bool}) +## Labels +(def: #export new-label + (-> Unit Label) + org.objectweb.asm.Label.new) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index 1fd87caea..39fab2f2a 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -1,6 +1,8 @@ (;module: lux - (lux (data (coll ["a" array] + (lux (data [text] + text/format + (coll ["a" array] [list "L/" Functor])) [host #+ jvm-import do-to]) ["$" ..] @@ -15,13 +17,26 @@ (#static ACC_PROTECTED int) (#static ACC_PRIVATE int) + (#static ACC_TRANSIENT int) + (#static ACC_VOLATILE int) + (#static ACC_ABSTRACT int) (#static ACC_FINAL int) (#static ACC_STATIC int) (#static ACC_SYNCHRONIZED int) - (#static ACC_TRANSIENT int) - (#static ACC_VOLATILE int)) + (#static ACC_SUPER int) + (#static ACC_INTERFACE int) + + (#static V1_1 int) + (#static V1_2 int) + (#static V1_3 int) + (#static V1_4 int) + (#static V1_5 int) + (#static V1_6 int) + (#static V1_7 int) + (#static V1_8 int) + ) (jvm-import org.objectweb.asm.FieldVisitor (visitEnd [] void)) @@ -41,15 +56,32 @@ (toByteArray [] Byte-Array)) ## [Defs] -(def: (exceptions-array type) - (-> $;Method (a;Array Text)) - (let [exs (|> type (get@ #$;exceptions) (L/map (|>. #$;Generic $t;descriptor))) - output (host;array String (list;size exs))] +(def: (string-array values) + (-> (List Text) (a;Array Text)) + (let [output (host;array String (list;size values))] (exec (L/map (function [[idx value]] (host;array-store idx value output)) - (list;enumerate exs)) + (list;enumerate values)) output))) +(def: exceptions-array + (-> $;Method (a;Array Text)) + (|>. (get@ #$;exceptions) + (L/map (|>. #$;Generic $t;descriptor)) + string-array)) + +(def: (version-flag version) + (-> $;Version Int) + (case version + #$;V1.1 Opcodes.V1_1 + #$;V1.2 Opcodes.V1_2 + #$;V1.3 Opcodes.V1_3 + #$;V1.4 Opcodes.V1_4 + #$;V1.5 Opcodes.V1_5 + #$;V1.6 Opcodes.V1_6 + #$;V1.7 Opcodes.V1_7 + #$;V1.8 Opcodes.V1_8)) + (def: (visibility-flag visibility) (-> $;Visibility Int) (case visibility @@ -58,6 +90,11 @@ #$;Private Opcodes.ACC_PRIVATE #$;Default 0)) +(def: (class-flag config) + (-> $;Class-Config Int) + ($_ i.+ + (if (get@ #$;finalC config) Opcodes.ACC_FINAL 0))) + (def: (method-flag config) (-> $;Method-Config Int) ($_ i.+ @@ -73,6 +110,87 @@ (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0) (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0))) +(def: class-to-type + (-> $;Class $;Type) + (|>. #$;Class #$;Generic)) + +(def: param-signature + (-> $;Class Text) + (|>. class-to-type $t;signature (format ":"))) + +(def: (formal-param [name super interfaces]) + (-> $;Parameter Text) + (format name + (param-signature super) + (|> interfaces + (L/map param-signature) + (text;join-with "")))) + +(def: (parameters-signature parameters super interfaces) + (-> (List $;Parameter) $;Class (List $;Class) + Text) + (let [formal-params (if (list;empty? parameters) + "" + (format "<" + (|> parameters + (L/map formal-param) + (text;join-with "")) + ">"))] + (format formal-params + (|> super class-to-type $t;signature) + (|> interfaces + (L/map (|>. class-to-type $t;signature)) + (text;join-with ""))))) + +(do-template [ ] + [(def: #export ( version visibility config name parameters super interfaces + definitions) + (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def + host;Byte-Array) + (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (ClassWriter.visit [(version-flag version) + ($_ i.+ + Opcodes.ACC_SUPER + + (visibility-flag visibility) + (class-flag config)) + name + (parameters-signature parameters super interfaces) + (|> super class-to-type $t;descriptor) + (|> interfaces + (L/map (|>. class-to-type $t;descriptor)) + string-array)])) + definitions) + _ (ClassWriter.visitEnd [] writer)] + (ClassWriter.toByteArray [] writer)))] + + [class 0] + [abstract Opcodes.ACC_ABSTRACT] + ) + +(def: $Object $;Class ["java.lang.Object" (list)]) + +(def: #export (interface version visibility config name parameters interfaces + definitions) + (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def + host;Byte-Array) + (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (ClassWriter.visit [(version-flag version) + ($_ i.+ + Opcodes.ACC_SUPER + Opcodes.ACC_INTERFACE + (visibility-flag visibility) + (class-flag config)) + name + (parameters-signature parameters $Object interfaces) + (|> $Object class-to-type $t;descriptor) + (|> interfaces + (L/map (|>. class-to-type $t;descriptor)) + string-array)])) + definitions) + _ (ClassWriter.visitEnd [] writer)] + (ClassWriter.toByteArray [] writer))) + (def: #export (method visibility config name type then) (-> $;Visibility $;Method-Config Text $;Method $;Inst $;Def) @@ -140,3 +258,15 @@ [char-field Char $t;char id] [string-field Text ($t;class "java.lang.String" (list)) id] ) + +(def: #export (fuse defs) + (-> (List $;Def) $;Def) + (case defs + #;Nil + id + + (#;Cons singleton #;Nil) + singleton + + (#;Cons head tail) + (. head (fuse tail)))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index f340be055..82b360883 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -18,25 +18,80 @@ (#static T_INT int) (#static T_LONG int) + (#static CHECKCAST int) + (#static NEW int) + (#static NEWARRAY int) + (#static ANEWARRAY int) + (#static DUP int) - (#static RETURN int) - (#static ARETURN int) + (#static DUP2_X1 int) + (#static POP int) + (#static POP2 int) + + (#static IF_ICMPEQ int) + (#static IF_ACMPEQ int) + (#static IFNULL int) + (#static GOTO int) + (#static ACONST_NULL int) + (#static ILOAD int) (#static ALOAD int) - (#static NEWARRAY int) - (#static ANEWARRAY int) + + (#static IADD int) + + (#static LAND int) + (#static LOR int) + (#static LXOR int) + (#static LSHL int) + (#static LSHR int) + (#static LUSHR int) + + (#static LADD int) + (#static LSUB int) + (#static LMUL int) + (#static LDIV int) + (#static LREM int) + (#static LCMP int) + + (#static DADD int) + (#static DSUB int) + (#static DMUL int) + (#static DDIV int) + (#static DREM int) + (#static DCMPG int) + + (#static I2L int) + (#static L2I int) + (#static L2D int) + (#static D2L int) + (#static I2C int) + + (#static AALOAD int) (#static AASTORE int) + (#static ARRAYLENGTH int) + + (#static GETSTATIC int) (#static PUTSTATIC int) (#static GETFIELD int) + (#static PUTFIELD int) + (#static INVOKESTATIC int) - (#static INVOKEVIRTUAL int) (#static INVOKESPECIAL int) - (#static CHECKCAST int)) + (#static INVOKEVIRTUAL int) + + (#static ATHROW int) + + (#static RETURN int) + (#static ARETURN int) + ) (jvm-import org.objectweb.asm.FieldVisitor (visitEnd [] void)) +(jvm-import org.objectweb.asm.Label + (new [])) + (jvm-import org.objectweb.asm.MethodVisitor (visitCode [] void) (visitMaxs [int int] void) @@ -47,9 +102,15 @@ (visitTypeInsn [int String] void) (visitVarInsn [int int] void) (visitIntInsn [int int] void) - (visitMethodInsn [int String String String boolean] void)) + (visitMethodInsn [int String String String boolean] void) + (visitLabel [Label] void) + (visitJumpInsn [int Label] void)) ## [Insts] +(def: #export (with-label action) + (-> (-> Label $;Inst) $;Inst) + (action (Label.new []))) + (do-template [ ] [(def: #export ( value) (-> $;Inst) @@ -72,11 +133,50 @@ (do-to visitor (MethodVisitor.visitInsn []))))] - [RETURN Opcodes.RETURN] - [ARETURN Opcodes.ARETURN] - [NULL Opcodes.ACONST_NULL] - [DUP Opcodes.DUP] - [AASTORE Opcodes.AASTORE] + [DUP Opcodes.DUP] + [DUP2_X1 Opcodes.DUP2_X1] + [POP Opcodes.POP] + [POP2 Opcodes.POP2] + + [NULL Opcodes.ACONST_NULL] + + [IADD Opcodes.IADD] + + [LAND Opcodes.LAND] + [LOR Opcodes.LOR] + [LXOR Opcodes.LXOR] + [LSHL Opcodes.LSHL] + [LSHR Opcodes.LSHR] + [LUSHR Opcodes.LUSHR] + + [LADD Opcodes.LADD] + [LSUB Opcodes.LSUB] + [LMUL Opcodes.LMUL] + [LDIV Opcodes.LDIV] + [LREM Opcodes.LREM] + [LCMP Opcodes.LCMP] + + [DADD Opcodes.DADD] + [DSUB Opcodes.DSUB] + [DMUL Opcodes.DMUL] + [DDIV Opcodes.DDIV] + [DREM Opcodes.DREM] + [DCMPG Opcodes.DCMPG] + + [I2L Opcodes.I2L] + [L2I Opcodes.L2I] + [L2D Opcodes.L2D] + [D2L Opcodes.D2L] + [I2C Opcodes.I2C] + + [AALOAD Opcodes.AALOAD] + [AASTORE Opcodes.AASTORE] + [ARRAYLENGTH Opcodes.ARRAYLENGTH] + + [ATHROW Opcodes.ATHROW] + + [RETURN Opcodes.RETURN] + [ARETURN Opcodes.ARETURN] ) (do-template [ ] @@ -97,7 +197,11 @@ (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 [ ] @@ -107,8 +211,9 @@ (do-to visitor (MethodVisitor.visitTypeInsn [ ($t;binary-name class)]))))] - [ANEWARRAY Opcodes.ANEWARRAY] [CHECKCAST Opcodes.CHECKCAST] + [NEW Opcodes.NEW] + [ANEWARRAY Opcodes.ANEWARRAY] ) (def: #export (NEWARRAY type) @@ -134,8 +239,28 @@ [INVOKESTATIC Opcodes.INVOKESTATIC] [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL] + [INVOKESPECIAL Opcodes.INVOKESPECIAL] ) +(do-template [ ] + [(def: #export ( @where) + (-> $;Label $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitJumpInsn [ @where]))))] + + [IF_ICMPEQ Opcodes.IF_ICMPEQ] + [IF_ACMPEQ Opcodes.IF_ACMPEQ] + [IFNULL Opcodes.IFNULL] + [GOTO Opcodes.GOTO] + ) + +(def: #export (label @label) + (-> $;Label $;Inst) + (function [visitor] + (do-to visitor + (MethodVisitor.visitLabel [@label])))) + (def: #export (array type size) (-> $;Type Nat $;Inst) (case type -- cgit v1.2.3