"

    Copyright (C) 2016-now Jan Vrany

    This code is not an open-source (yet). You may use this code

    for your own experiments and projects, given that:

    * all modification to the code will be sent to the

      original author for inclusion in future releases

    * this is not used in any commercial software

    This license is provisional and may (will) change in

    a future.

"

"{ Package: 'jv:dragonfly/c1' }"

"{ NameSpace: DragonFly }"

Object subclass:#C1Compiler

	instanceVariableNames:'method module function asm prologue epilogue contextSetup

	classVariableNames:'SelectorSpecialCharMappingTable'

	poolDictionaries:'DragonFly::C1LLVMTypes LLVMIntPredicate VMData VMOffsets

		VMConstants'

	category:'DragonFly-C1'

!

!C1Compiler class methodsFor:'documentation'!

copyright

"

    Copyright (C) 2016-now Jan Vrany

    This code is not an open-source (yet). You may use this code

    for your own experiments and projects, given that:

    * all modification to the code will be sent to the

      original author for inclusion in future releases

    * this is not used in any commercial software

    This license is provisional and may (will) change in

    a future.

"

! !

!C1Compiler class methodsFor:'class initialization'!

initialize

    "Invoked at system start or when the class is dynamically loaded."

    "/ please change as required (and remove this comment)

    SelectorSpecialCharMappingTable := Dictionary withKeysAndValues:

                #($+ 'pl'

                  $- 'mi'

                  $* 'mu'

                  $/ 'di'

                  $, 'co'

                  $@ 'at'

                  $< 'le'

                  $> 'gr'

                  $= 'eq'

                  $~ 'ne'

                  $| 'pi'

                  $\ 'mo'

                  $& 'am').

    "Created: / 09-02-2016 / 08:43:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler class methodsFor:'compilation'!

compile: method

    ^ self new compile: method

    "Created: / 09-02-2016 / 08:47:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler class methodsFor:'utilities'!

functionNameForClass: class selector: selector      

    "For given class name and selector, returns the name 

     used by LLVM"

    ^ String streamContents:[ :s|

        s nextPutAll: '__M_D_'.

        s nextPutAll: (class name copyReplaceAll: $: with: $_).

        s nextPut: $_.

        selector isBinarySelector ifTrue:[ 

            selector do:[:c |     

                s nextPutAll: (SelectorSpecialCharMappingTable at: c)

            ].

        ] ifFalse:[ 

            selector do:[:c |  

                c isAlphaNumeric ifTrue:[ 

                    s nextPut: c 

                ] ifFalse:[

                    s nextPut: $_.

                    c == $: ifFalse:[ 

                        c codePoint printOn: s.

                    ]

                ].

            ]

        ].

    ].

    "

    C1Compiler functionNameForClass: C1Compiler selector: #functionNameForClass:selector: 

    C1Compiler functionNameForClass: SmallInteger selector: #+

    C1Compiler functionNameForClass: Object selector: #~=

    C1Compiler functionNameForClass: JavaVM selector: #_ALOAD:

    "

    "Created: / 09-02-2016 / 08:44:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler methodsFor:'accessing'!

functionSEND: nArgs

    | name |

    self assert: (nArgs between: 0 and:15).

    name := '_SEND', nArgs printString.

    ^ self functionNamed: name type: (TyOBJFUNCs at: nArgs + 1).

    "Created: / 20-04-2016 / 21:39:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 17-06-2016 / 23:25:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

function__MKREALCONTEXT5

    ^ self functionNamed: '__MKREALCONTEXT5' type: TyMKREALCONTEXT5

    "Created: / 17-06-2016 / 23:25:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

method

    ^ method

!

method:aMethod

    method := aMethod.

! !

!C1Compiler methodsFor:'compilation'!

compile: aMethod

    self method: aMethod.

    self prepare.

    self prologue.

    self epilogue.

    self finish.

    "Created: / 09-02-2016 / 08:52:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-04-2016 / 09:18:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

finish

    "Finish the compilation, i.e., generate machine code

     and update method's code pointer"

    | opts mm object jit literalsSection |

    module verify.

    mm := C1LLVMMCJITMemoryManager for: object.

    opts := LLVMMCJITCompilerOptions new.

    opts MCJMM: mm.

    jit := LLVMExecutionEngine newForModule: module options: opts.

    method code: (jit addressOfFunction: function).

    "Created: / 21-04-2016 / 09:19:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

prepare

    | name |

    name := self class functionNameForClass: method mclass ? UndefinedObject selector: method selector ? '<unbound>'.

    module := LLVMModule newWithName: name.

    function := module addFunctionNamed: name type: (TyOBJFUNCs at: method numArgs + 1).

    (function parameterAt: OBJFUNCArgIndexReceiver) name: 'zelf'.

    (function parameterAt: OBJFUNCArgIndexSelector) name: 'selector'.

    (function parameterAt: OBJFUNCArgIndexSearchClass) name: 'searchClass'.

    (function parameterAt: OBJFUNCArgIndexILC) name: 'pilc'.

    1 to: method numArgs do:[:i | (function parameterAt: OBJFUNCArgIndexArgBase + i) name: 'arg' , i printString ].

    asm := function builder.

    literals := OrderedCollection with: method.

    "Created: / 21-04-2016 / 09:17:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler methodsFor:'private'!

epilogue

    asm continue: epilogue.

    asm ret: 

        (asm call: self function__MKREALCONTEXT5

                _: { self loadRetvalTemp })

    "Created: / 15-04-2016 / 23:38:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 17-06-2016 / 23:27:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

functionNamed: name type: type

    | f |

    f := module getFunctionNamed: name.

    f isNil ifTrue:[ 

        f := module addFunctionNamed: name type: type

    ].

    ^ f

    "Created: / 17-06-2016 / 23:23:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

prologue

    | classOfReceiver classInILC classCheck |

    prologue := function addBasicBlockNamed: 'prologue'.

    epilogue := function addBasicBlockNamed: 'epilogue'.

    asm continue: prologue.

    classOfReceiver := self loadClassOf:(function parameterAt:OBJFUNCArgIndexReceiver).

    classInILC := self loadClassFromILC:(function parameterAt:OBJFUNCArgIndexILC).

    classCheck := asm icmp: (asm ptr: classOfReceiver toInt: LLVMType intptr)

                         _: (asm ptr: classInILC toInt: LLVMType intptr)

                      cond: LLVMIntNE.

    asm if: classCheck"failed" then: [

        "/ Class check failed, call _SENDX()"

        asm ret: (

            asm call: (self functionSEND:method numArgs) _: { 

                function parameterAt: OBJFUNCArgIndexReceiver.

                function parameterAt: OBJFUNCArgIndexSelector.

                function parameterAt: OBJFUNCArgIndexSearchClass.

                function parameterAt: OBJFUNCArgIndexILC } , 

                (1 to: method numArgs collect:[:i | function parameterAt: OBJFUNCArgIndexArgBase + i ])

        ).

    ].

    self contextSetup.

    asm continue: (function addBasicBlockNamed:'body').

    "Created: / 09-02-2016 / 17:07:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 17-06-2016 / 23:32:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler methodsFor:'private-context setup'!

contextSetup

    | flags |

    contextSetup := function addBasicBlockNamed:'context-setup'.

    asm continue:contextSetup.

    context := asm alloca:(C1LLVMTypes tyContext:(method numArgs + method numVars + method numTemps))

                       as:'__context'.

    flags :=   (method isJavaMethod ifTrue:[ __LAZYJCON ] ifFalse:[ method isBlock ifTrue:[ __LAZYBCON ] ifFalse:[ __LAZYMCON ]])

             | __CANNOT_RETURN "/ For now, we don't (yet) fill setjmp() buffer

             | (method numArgs  bitShift: __NARG_SHIFT)

             | (method numVars  bitShift: __NVAR_SHIFT)

             | (method numTemps bitShift: __NTMP_SHIFT).

    asm store:(self loadSmallInteger: flags)  

           at:(asm gep:context at:{ 0 . TyContextFieldIndexFlags }).

    asm store:self loadReceiver

          at:(asm gep:context at:{ 0 . TyContextFieldIndexReceiver }).

    asm store:self loadSelector

           at:(asm gep:context at:{ 0 . TyContextFieldIndexSelector }).

    asm store:self loadSearchClass

           at:(asm gep:context at:{ 0 . TyContextFieldIndexSearchClass }).

    asm store:(asm bitcast: self loadThisContext to: LLVMType intptr pointer)

           at:(asm gep:context at:{ 0 . TyContextFieldIndexSenderS }).

    self storeThisContext: context.

    "Created: / 20-04-2016 / 23:12:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler methodsFor:'private-load / store'!

loadClassFromILC:pIlc 

    self assert:pIlc type = TyInlineCachePtr.

    ^ asm load:(asm gep:pIlc at:{ 0 . TyInlineCacheIndexClass })

             "Created: / 12-02-2016 / 13:19:19 / Jan Vrany <jan.vrany@fit.cvut.cz>" "Modified: / 15-04-2016 / 23:18:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadClassOf:obj

    | class1 class2 class3 class23|

    asm if: (self isNilObject: obj) then:[ 

        class1 := self loadClassUndefinedObject.

    ] else: [ 

        asm if: (self isSmallIntegerObject:obj) then: [

            class2 := self loadClassSmallInteger.

        ] else:[  

            class3 := (asm load:(asm gep:obj at:{ 0 . TyInstanceFieldIndexClass })).

        ].

        class23 := asm phi: { class2 . class3 }.

    ].

    ^ asm phi: { class1 . class23 }

    "Created: / 09-02-2016 / 17:25:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 18-06-2016 / 20:50:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadClassSmallInteger

    | addr |

    addr := asm 

                int:(LLVMConstant uintptr:ADDR_SmallInteger)

                toPtr:TyOBJ pointer

                as:'ADDR_SmallInteger'.

    ^ asm load:addr as: 'SmallInteger'.

    "Created: / 12-02-2016 / 11:54:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-04-2016 / 17:03:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadClassUndefinedObject

    | addr |

    addr := asm 

                int:(LLVMConstant uintptr:ADDR_UndefinedObject )

                toPtr:TyOBJ pointer

                as:'ADDR_UndefinedObject'.

    ^ asm load:addr as: 'UndefinedObject'.

    "Created: / 18-06-2016 / 00:47:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadNil

    "Created: / 21-04-2016 / 13:59:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadReceiver

    ^ context isNil 

        ifTrue:[ function parameterAt: OBJFUNCArgIndexReceiver ]

    "Created: / 20-04-2016 / 22:09:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadRetvalTemp

    self assert: context notNil description: 'No context!!'.

    ^ asm load: (asm gep: context at:{ 0 . TyContextFieldIndexRetvalTemp }) as: 'retvalTemp'

    "Created: / 17-06-2016 / 23:13:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadSearchClass

    ^ context isNil 

        ifTrue:[ function parameterAt: OBJFUNCArgIndexSearchClass ]

    "Created: / 20-04-2016 / 23:27:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadSelector

    ^ context isNil 

        ifTrue:[ function parameterAt: OBJFUNCArgIndexSelector ]

    "Created: / 20-04-2016 / 23:24:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadSmallInteger: value

    self assert: (value between: SmallInteger minVal and: SmallInteger maxVal).

    "Created: / 18-06-2016 / 22:15:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

loadThisContext

    | addr |

    addr := asm 

                int:(LLVMConstant uintptr:ADDR___thisContext)

                toPtr:TyOBJ pointer

                as:'ADDR___thisContext'.

    ^ asm load:addr as: '__thisContext'.

    "Created: / 17-06-2016 / 23:38:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

storeRetvalTemp: value

    self assert: context notNil description: 'No context!!'.

    ^ asm store: value at: (asm gep: context at:{ 0 . TyContextFieldIndexRetvalTemp })

    "Created: / 17-06-2016 / 23:14:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

storeThisContext: value

    | addr valueAsOBJ |

    valueAsOBJ := value type = TyOBJ 

        ifTrue:[ value ]

        ifFalse:[ asm bitcast: value to: TyOBJ ].

    addr := asm 

                int:(LLVMConstant uintptr:ADDR___thisContext)

                toPtr:TyOBJ pointer

                as:'ADDR___thisContext'.

    asm store: valueAsOBJ at: addr.

    "Created: / 17-06-2016 / 23:38:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler methodsFor:'private-testing'!

isNilObject: value

    self assert: value type = TyOBJ.

    ^ asm icmp: (asm ptr: value toInt: LLVMType intptr)

             _: (LLVMConstant uintptr: 0)

          cond: LLVMIntEQ

    "Created: / 18-06-2016 / 00:48:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

isSmallIntegerObject: value

    self assert: value type = TyOBJ.

    ^ asm icmp: (asm and: (asm ptr: value toInt: LLVMType intptr) _: (LLVMConstant uintptr: 1))

             _: (LLVMConstant uintptr: 1)

          cond: LLVMIntEQ

    "Created: / 09-02-2016 / 17:30:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 12-02-2016 / 11:55:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!C1Compiler class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !

C1Compiler initialize!