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

"{ NameSpace: DragonFly }"

Object subclass:#C1Compiler
	instanceVariableNames:'method module function asm prologue epilogue'
	classVariableNames:'SelectorSpecialCharMappingTable'
	poolDictionaries:'DragonFly::C1LLVMMTypes LLVMIntPredicate VMData VMOffsets'
	category:'DragonFly-C1'
!

!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:'compilation'!

compile: aMethod
    | name |
    method := aMethod.
    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).
    asm := LLVMIRBuilder new.
    self prologue.

    self epilogue.

    "Created: / 09-02-2016 / 08:52:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-04-2016 / 23:38:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!C1Compiler methodsFor:'private'!

epilogue
    self halt.

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

prologue
    | classOfReceiver classInILC classCheckFailedBlock classCheckPassedBlock classCheck |
    prologue := function addBasicBlockNamed: 'prologue'.
    asm block: prologue.
    classOfReceiver := self fetchClassOf: (function parameterAt: OBJFUNCArgIndexReceiver ).
    classInILC := self fetchClassFromILC: (function parameterAt: OBJFUNCArgIndexILC ).
    classCheckFailedBlock := function addBasicBlockNamed: 'prologue.class-check-failed'. 
    classCheckPassedBlock := function addBasicBlockNamed: 'prologue.class-check-passed'.
    classCheck := asm icmp: (asm ptr: classOfReceiver toInt: LLVMType intptr)
                         _: (asm ptr: classInILC toInt: LLVMType intptr)
                      cond: LLVMIntEQ.
    asm if: classCheck then: classCheckPassedBlock else: classCheckFailedBlock.

    "/ Class check failed, call _SENDX()"
    asm block: classCheckFailedBlock.


    "/ Classes match, continue.
    asm block: classCheckPassedBlock.

    "Created: / 09-02-2016 / 17:07:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-04-2016 / 23:45:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

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

fetchClassFromILC: 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>"
!

fetchClassOf:obj 
    ^ asm 
        select:(self isSmallIntegerObject:obj)
        then: self fetchClassSmallInteger
        else: (asm load: (asm gep:obj at: { 0 . TyInstanceIndexClass })).

    "Created: / 09-02-2016 / 17:25:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 15-04-2016 / 23:19:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

fetchClassSmallInteger
    | addr |

    addr := asm int: (LLVMConstant uintptr: ADDR_SmallInteger) toPtr: TyOBJ pointer.
    ^ asm load: addr.

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

!C1Compiler methodsFor:'private-testing'!

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 initialize!