Initial support for message sends.
For now, the C1 compiler uses simple `__SSENDx`s so no need to bother with
inline caches. This can (and will) be addressed in a future.
"
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
literals literalsBaseAddr context stack'
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>"
!
function__SSEND: nArgs
| name |
self assert: (nArgs between: 0 and:15).
name := '__SSEND', nArgs printString.
^ self functionNamed: name type: (TySSENDSs at: nArgs + 1).
"Created: / 23-06-2016 / 22:04:36 / 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 |
object := CompiledCodeObject forCompiledCode: method text: 0 literals: literals size ilcs: 0.
literals notEmptyOrNil ifTrue:[
literalsSection := object literals.
1 to: literals size do:[:i |
literalsSection at: i put: (literals at: i).
].
literalsBaseAddr initializer: (LLVMConstant pointer: literalsSection address type: TyOBJVec)
].
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>"
"Modified: / 20-06-2016 / 09:22:34 / 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.
literalsBaseAddr := module addGlobalNamed: '__literals' value: (LLVMConstant null: TyOBJVec)
"Created: / 21-04-2016 / 09:17:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 20:28:18 / 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 loadLiteral: method)
at:(asm gep:context at:{ 0 . TyContextFieldIndexMethod }).
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>"
"Modified: / 20-06-2016 / 20:44:18 / 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>"
!
loadLiteral: anObject
| index |
anObject class == SmallInteger ifTrue:[
^ self loadSmallInteger: anObject.
].
anObject isNil ifTrue:[
^ self loadNil.
].
index := literals identityIndexOf: anObject.
index == 0 ifTrue:[
literals add: anObject.
index := literals size.
].
^ asm load: (asm gep: (asm load: literalsBaseAddr) at: index - 1)
as: ('literal_', index printString)
"Created: / 20-06-2016 / 20:41:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:35:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
loadNil
^ asm int:(LLVMConstant uintptr:0) toPtr:TyOBJ as: 'nil'
"Created: / 21-04-2016 / 13:59:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:36:50 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
loadReceiver
^ context isNil
ifTrue:[ function parameterAt: OBJFUNCArgIndexReceiver ]
ifFalse:[ asm load: (asm gep: context at:{ 0 . TyContextFieldIndexReceiver }) as: 'zelf' ]
"Created: / 20-04-2016 / 22:09:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:37:09 / 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 ]
ifFalse:[ asm load: (asm gep: context at:{ 0 . TyContextFieldIndexSearchClass }) as: 'searchClass' ]
"Created: / 20-04-2016 / 23:27:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:37:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
loadSelector
^ context isNil
ifTrue:[ function parameterAt: OBJFUNCArgIndexSelector ]
ifFalse:[ asm load: (asm gep: context at:{ 0 . TyContextFieldIndexSelector }) as: 'selector']
"Created: / 20-04-2016 / 23:24:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:37:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
loadSmallInteger: value
self assert: (value between: SmallInteger minVal and: SmallInteger maxVal).
^asm int: (LLVMConstant sintptr: (value << 1) + 1) toPtr: TyOBJ as:'smallint_', value printString
"Created: / 18-06-2016 / 22:15:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-06-2016 / 23:37:55 / 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-sends'!
emitSend: selector to: receiver with: arguments
self assert: (arguments size between: 0 and: 15) description: 'Invalid number of arguments. VM supports max 15 args'.
^ asm call: (self function__SSEND: arguments size) _: {
receiver . "/ receiver
self loadLiteral: selector ."/ selector
LLVMConstant sint32: 0. "/ lineNr (no line info for now)
} , arguments
"Created: / 23-06-2016 / 22:17:35 / 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!