Re: [Help-smalltalk] compiling method attributes

[Paolo Bonzini]

Stephen Compall wrote:
> http://scompall.nocandysw.com/gst/gst-methodAttributes-comp.diff puts in
> place a simple framework for compiling attributes like <cCall:...> and
> <primitive:...> in STCompiler.  It also includes some fixes for
> RBMethodNode>>#start, #stop

This one seems wrong, you need "self start + source size - 1" IMO?

 and PositionableStream>>#copyFrom:to:, as
> these are necessary for stream-based compilation tests.  It assumes
> compiler-cascade.diff is applied.

Yeah, I committed it.

> This does not include actual compilation of any attribute tags, but it
> does parse them and warn when a given type is unimplemented.

Except #primitive:, compilation of attributes is taken care by blocks 
registered with the classes and returned by Class>>#pragmaHandlerFor: 
(if it returns nil, the attribute has no compile-time semantics).  With 
the usual bugs due to lack of good unit tests...

The blocks are evaluated passing the CompiledMethod and the attribute (a 
Message), and their return value is nil or an error message.

> It will probably break on filing in because FileSegment can be used for
> RBMethodNode's source instvar, which doesn't support copyFrom:to:.

Then let's add it.  :-)

> (Wondering what's causing the "duplicate variable name" warnings.  Oh
> well, some other time, more testing)

I get them too, let's see who gets it first.

The attached patch may require some work to retrofit into your (patched) 
2.3 tree, but I will backport the entire set to my arch repository later.

Thanks,

Paolo

* looking for address@hidden/smalltalk--devo--2.2--patch-231 to compare with
* comparing to address@hidden/smalltalk--devo--2.2--patch-231
M  compiler/RBParseNodes.st
M  compiler/RBParser.st
M  compiler/STCompiler.st
M  kernel/Class.st
M  kernel/FileSegment.st
M  kernel/PosStream.st

* modified files

--- orig/compiler/RBParseNodes.st
+++ mod/compiler/RBParseNodes.st
@@ -953,8 +953,11 @@ children
     ^self arguments copyWith: self body!
 
 primitiveSources
+    | offset |
+    offset := self start - 1.
     ^self tags 
-       collect: [:each | self source copyFrom: each first to: each last]!
+       collect: [:each | self source copyFrom: each first - offset
+                                     to: each last - offset]!
 
 isBinary
     ^(self isUnary or: [self isKeyword]) not!
@@ -991,10 +994,13 @@ source: anObject
     source := anObject!
 
 start
+    (selectorParts notNil and: [ selectorParts first start notNil ])
+       ifTrue: [ ^selectorParts first start ].
+    body start isNil ifFalse: [ ^body start ].
     ^1!
 
 stop
-    ^source size!
+    ^self start + source size - 1!
 
 tags
     ^tags isNil ifTrue: [#()] ifFalse: [tags]!


--- orig/compiler/RBParser.st
+++ mod/compiler/RBParser.st
@@ -97,6 +97,9 @@ scanner: aScanner 
 addCommentsTo: aNode
     aNode comments: scanner getComments!
 
+currentToken
+    ^currentToken!
+
 nextToken
     ^nextToken isNil
        ifTrue: [nextToken := scanner next]
@@ -153,6 +156,14 @@ parseBinaryMessage
            whileTrue: [node := self parseBinaryMessageWith: node].
     ^node!
 
+parseBinaryMessageNoGreater
+    | node |
+    node := self parseUnaryMessage.
+
+    [ currentToken isBinary and: [currentToken value ~~ #>] ]
+            whileTrue: [node := self parseBinaryMessageWith: node].
+    ^node!
+
 parseBinaryMessageWith: aNode 
     | binaryToken |
     binaryToken := currentToken.


--- orig/compiler/STCompiler.st
+++ mod/compiler/STCompiler.st
@@ -419,7 +419,7 @@ acceptSequenceNode: node
 !STCompiler methodsFor: 'visiting RBMethodNodes'!
 
 acceptMethodNode: node
-    | statements method |
+    | statements method attributes |
     node body addSelfReturn.
 
     depth := maxDepth := 0.
@@ -429,11 +429,12 @@ acceptMethodNode: node
     self undeclareArgumentsAndTemporaries: node.
     symTable finish.
 
+    attributes := self compileMethodAttributes: node primitiveSources.
     method := CompiledMethod
        literals: symTable literals
        numArgs: node arguments size
        numTemps: node body temporaries size
-       attributes: #()
+       attributes: attributes
        bytecodes: bytecodes contents
        depth: maxDepth + node body temporaries size + node arguments size.
 
@@ -442,6 +443,12 @@ acceptMethodNode: node
        methodClass: symTable environment;
        selector: node selector.
 
+    method attributesDo: [ :ann || handler error |
+       handler := symTable environment pragmaHandlerFor: ann selector.
+       handler notNil ifTrue: [
+           error := handler value: method value: ann.
+           error notNil ifTrue: [ self compileError: error ] ] ].
+
     ^method
 ! !
 
@@ -934,4 +941,44 @@ compileStoreTemporary: number scopes: ou
        arg: number
 ! !
 
+"--------------------------------------------------------------------"
+
+!STCompiler methodsFor: 'compiling method attributes'!
+
+compileMethodAttributes: attributes
+    ^attributes asArray collect: [ :each |
+       self compileAttribute: (RBScanner on: each readStream) ]!
+
+scanTokenFrom: scanner
+    scanner atEnd
+       ifTrue: [^self compileError: 'method attributes must end with ''>'''].
+    ^scanner next!
+
+compileAttribute: scanner
+    | currentToken selectorBuilder selector arguments parser node |
+    currentToken := self scanTokenFrom: scanner.
+    (currentToken isBinary and: [currentToken value == #<])
+       ifFalse: [^self compileError:
+                     'method attributes must begin with ''<'''].
+
+    selectorBuilder := WriteStream on: String new.
+    arguments := WriteStream on: Array new.
+    currentToken := self scanTokenFrom: scanner.
+    [ currentToken isBinary and: [currentToken value == #>] ] whileFalse: [
+       currentToken isKeyword
+           ifFalse: [^self compileError: 'keyword expected in method 
attribute'].
+       selectorBuilder nextPutAll: currentToken value.
+
+        parser := RBParser new.
+        parser errorBlock: parser errorBlock.
+        parser scanner: scanner.
+        node := parser parseBinaryMessageNoGreater.
+       node := RBSequenceNode statements: {node}.
+       arguments nextPut: (self class evaluate: node parser: parser).
+       currentToken := parser currentToken.
+    ].
+
+    selector := selectorBuilder contents asSymbol.
+    ^Message selector: selector arguments: arguments contents! !
+
 STCompiler initialize!


--- orig/kernel/Class.st
+++ mod/kernel/Class.st
@@ -496,7 +496,7 @@ registerHandler: aBlock forPragma: pragm
 pragmaHandlerFor: aSymbol
     | handler |
     pragmaHandlers isNil ifFalse: [
-       handler := self pragmaHandlers at: aSymbol ifAbsent: [ nil ]
+       handler := pragmaHandlers at: aSymbol ifAbsent: [ nil ].
        handler isNil ifFalse: [ ^handler ].
     ].
     self superclass isNil ifFalse: [


--- orig/kernel/FileSegment.st
+++ mod/kernel/FileSegment.st
@@ -70,6 +70,25 @@ on: aFile startingAt: startPos for: size
 
 !FileSegment methodsFor: 'basic'!
 
+copyFrom: from to: to
+    "Answer a String containing the given subsegment of the file.  As for
+     streams, from and to are 0-based."
+    (to between: 0 and: size - 1) ifFalse: [
+        ^SystemExceptions.ArgumentOutOfRange
+           signalOn: to
+           mustBeBetween: 0
+           and: size - 1 ].
+    (from between: 0 and: to) ifFalse: [
+        from = to + 1 ifTrue: [ ^self species new ].
+        ^SystemExceptions.ArgumentOutOfRange
+           signalOn: from
+           mustBeBetween: 0
+           and: to + 1 ].
+
+    ^self withFileDo: [ :fileStream | 
+       fileStream copyFrom: startPos + from to: startPos + to ]
+!
+
 asString
     "Answer a String containing the required segment of the file"
     ^self withFileDo: [ :fileStream | 
@@ -139,6 +158,10 @@ hash
 
 !FileSegment methodsFor: 'private'!
 
+species
+    ^String
+!
+
 getFile
     ^file
 !