Mercurial Mercurial > hg > stx-libtool / changeset
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | raw | zip | gz | bz2 | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
- SmallSenseTypeHolder jv
authorJan Vrany <jan.vrany@fit.cvut.cz>
Fri, 18 May 2012 00:16:11 +0100
branchjv
changeset 12248 a97c6f2acc13
parent 12247 1bd3e7f3c9c9
child 12249 8c861bdf7f51
- SmallSenseTypeHolder added: #trustfullness #trustfullness: #trustfullnessAdd: category of: - SmallSenseType class definition added: #trustfullness #trustfullness: #trustfullnessAdd: - SmallSenseClassType class definition added: #trustfullness #trustfullness: changed: #klass: - SmallSenseUnionType class definition added:9 methods changed: #addType: #addTypes: #types: category of: - SmallSenseUnknownType added: #trustfullness #trustfullness: - extensions ...
smallsense/SmallSenseClassType.st file | annotate | diff | comparison | revisions
smallsense/SmallSenseInferencer.st file | annotate | diff | comparison | revisions
smallsense/SmallSenseType.st file | annotate | diff | comparison | revisions
smallsense/SmallSenseTypeHolder.st file | annotate | diff | comparison | revisions
smallsense/SmallSenseUnionType.st file | annotate | diff | comparison | revisions
smallsense/SmallSenseUnknownType.st file | annotate | diff | comparison | revisions
smallsense/smallsense.rc file | annotate | diff | comparison | revisions 
--- a/smallsense/SmallSenseClassType.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseClassType.st	Fri May 18 00:16:11 2012 +0100
@@ -1,7 +1,7 @@
 "{ Package: 'stx:libtool/smallsense' }"
 
 SmallSenseType subclass:#SmallSenseClassType
-	instanceVariableNames:'klass'
+	instanceVariableNames:'trustfullness klass'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'SmallSense-Types'
@@ -16,6 +16,26 @@
 
 klass:aClass
     klass := aClass.
+
+    "Some manual trustfullness tweaks"
+
+    klass == Object ifTrue:[
+        self trustfullnessAdd: -10. 
+    ]
+
+    "Modified: / 17-05-2012 / 19:59:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullness
+    ^ trustfullness ? 20
+
+    "Modified: / 17-05-2012 / 19:35:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullness:something
+    trustfullness := something min: 100.
+
+    "Modified: / 17-05-2012 / 19:46:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !SmallSenseClassType methodsFor:'comparing'!
@@ -85,5 +105,5 @@
 !SmallSenseClassType class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseClassType.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseClassType.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
--- a/smallsense/SmallSenseInferencer.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseInferencer.st	Fri May 18 00:16:11 2012 +0100
@@ -291,22 +291,26 @@
     "Created: / 26-11-2011 / 13:53:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
-visitBlockNode:anObject 
+visitBlockNode:anObject
+    | type |
 
     super visitBlockNode:anObject.
+    type := (SmallSenseType withClass: BlockClosure).
+    type trustfullness: 100.
+    anObject inferedType: type.
 
-    anObject inferedType: (SmallSenseType withClass: BlockClosure)
-
-    "Modified: / 25-07-2011 / 22:45:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
     "Created: / 26-11-2011 / 14:46:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
 visitConstantNode:anObject
-
     "Type of a constant is trivially its value class"
 
+    | type |
+
     super visitConstantNode: anObject.
-    anObject inferedType: (SmallSenseType withClass: anObject value class)
+    type := (SmallSenseType withClass: anObject value class).
+    type trustfullness: 100.
+    anObject inferedType: type.
 
     "Created: / 26-11-2011 / 13:55:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
@@ -361,6 +365,7 @@
         rec := anObject receiver.                        
         (rec isSelf and:[class isMetaclass]) ifTrue:[
             type := SmallSenseType withClass: class theNonMetaclass.
+            type trustfullnessAdd: 50.
             anObject inferedType: type.
             ^self.
         ].
@@ -379,15 +384,17 @@
 
     "Following code ensures, that all variable nodes refering same
      variable shares the inferred type"
-    t := types at: anObject name ifAbsentPut:[SmallSenseType default].
+    t := types at: anObject name ifAbsentPut:[SmallSenseType unknown].
     anObject inferedType: t.
 
     anObject isGlobalVariable ifTrue:[
-        t addClass: (Smalltalk at: anObject name) class.        
+        t addClass: (Smalltalk at: anObject name) class.
+        t trustfullness: 100.
         ^self.
     ].
     anObject isClassVariable ifTrue:[
         t addClass: (class theNonMetaclass classVarAt: anObject name asSymbol) class.
+        t trustfullness: 100.
         ^self.
     ].
 
@@ -415,5 +422,5 @@
 !SmallSenseInferencer class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseInferencer.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseInferencer.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
--- a/smallsense/SmallSenseType.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseType.st	Fri May 18 00:16:11 2012 +0100
@@ -1,7 +1,7 @@
 "{ Package: 'stx:libtool/smallsense' }"
 
 Object subclass:#SmallSenseType
-	instanceVariableNames:'trustfullness'
+	instanceVariableNames:''
 	classVariableNames:'ObjectType'
 	poolDictionaries:''
 	category:'SmallSense-Types'
@@ -62,6 +62,33 @@
     "Created: / 26-11-2011 / 14:14:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
+!SmallSenseType methodsFor:'accessing'!
+
+trustfullness
+    "Return an integer value in <1..100>, higher value
+     means the object is more likely of that type."
+
+    ^self subclassResponsibility
+
+    "Created: / 17-05-2012 / 19:20:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullness: anInteger
+    "Set the trustfullness"
+
+    ^self subclassResponsibility
+
+    "Created: / 17-05-2012 / 19:43:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullnessAdd: anInteger 
+    "Advance mu trustfullness by an Integer"
+
+    self trustfullness: self trustfullness + anInteger
+
+    "Created: / 17-05-2012 / 19:46:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !SmallSenseType methodsFor:'comparing'!
 
 = another
@@ -172,7 +199,7 @@
 !SmallSenseType class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseType.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseType.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
 
 SmallSenseType initialize!
--- a/smallsense/SmallSenseTypeHolder.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseTypeHolder.st	Fri May 18 00:16:11 2012 +0100
@@ -19,6 +19,24 @@
 
 !SmallSenseTypeHolder methodsFor:'accessing'!
 
+trustfullness
+    ^type trustfullness
+
+    "Created: / 17-05-2012 / 19:50:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullness:aSmallInteger
+    type trustfullness:aSmallInteger
+
+    "Created: / 17-05-2012 / 19:50:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullnessAdd: anInteger
+    type trustfullnessAdd: anInteger
+
+    "Created: / 17-05-2012 / 19:50:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 type
     ^ type
 !
@@ -133,5 +151,5 @@
 !SmallSenseTypeHolder class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseTypeHolder.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseTypeHolder.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
--- a/smallsense/SmallSenseUnionType.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseUnionType.st	Fri May 18 00:16:11 2012 +0100
@@ -1,7 +1,7 @@
 "{ Package: 'stx:libtool/smallsense' }"
 
 SmallSenseType subclass:#SmallSenseUnionType
-	instanceVariableNames:'types'
+	instanceVariableNames:'types trustfullness trustfullnessBonus'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'SmallSense-Types'
@@ -10,6 +10,30 @@
 
 !SmallSenseUnionType methodsFor:'accessing'!
 
+trustfullness
+    "Return an integer value in <1..100>, higher value
+     means the object is more likely of that type."
+
+    ^ self shouldImplement
+!
+
+trustfullness: anInteger
+    "Remember the bonus/malus given by an inferences"
+
+    trustfullnessBonus := anInteger - trustfullness.
+    trustfullness := anInteger min: 100.
+
+    "Created: / 17-05-2012 / 19:43:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullnessAdd: anInteger
+
+    trustfullnessBonus := (trustfullnessBonus ? 0) + anInteger.
+    trustfullness := trustfullness + anInteger.
+
+    "Created: / 17-05-2012 / 19:47:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
 types
     ^ types ? #()
 
@@ -18,12 +42,33 @@
 
 types:something
     types := something.
+    self updateTrustfullness
+
+    "Modified: / 17-05-2012 / 19:23:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !SmallSenseUnionType methodsFor:'adding & removing'!
 
 addType: typeOrHolder
 
+   self basicAddType: typeOrHolder.
+   self prune
+
+    "Created: / 16-12-2011 / 01:50:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+addTypes: typeOrHolder
+
+   self basicAddTypes: typeOrHolder.
+   self prune
+
+    "Created: / 16-12-2011 / 01:51:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmallSenseUnionType methodsFor:'adding & removing-private'!
+
+basicAddType: typeOrHolder
+
     | type |
     typeOrHolder isTypeHolder ifTrue:[
         type := typeOrHolder type
@@ -33,7 +78,7 @@
 
     types isNil ifTrue:[types := OrderedCollection new].
     type isUnionType ifTrue:[
-        self addTypes: type types.
+        self basicAddTypes: type types.
     ] ifFalse:[
         type isUnknownType ifFalse:[
             (types includes: type) ifFalse:[
@@ -42,14 +87,14 @@
         ]
     ].
 
-    "Created: / 16-12-2011 / 01:50:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Created: / 17-05-2012 / 19:27:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 
-addTypes: someTypes
+basicAddTypes: someTypes
 
-    someTypes do:[:each|self addType: each].
+    someTypes do:[:each|self basicAddType: each ].
 
-    "Created: / 16-12-2011 / 01:51:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Created: / 17-05-2012 / 19:28:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
 !SmallSenseUnionType methodsFor:'comparing'!
@@ -129,6 +174,35 @@
     "Modified: / 16-12-2011 / 01:54:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
+!SmallSenseUnionType methodsFor:'private'!
+
+prune
+    "Prune the types - remove less likely types."
+
+    self updateTrustfullness.   
+    types size < 1 ifTrue:[ ^ self ].
+
+    "Experimental - remove those with trustfullness less than mine"
+    
+    types := types reject:[:type|type trustfullness < trustfullness ].
+
+    "Created: / 17-05-2012 / 19:38:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+updateTrustfullness
+    "Recompute the trustfullness, This is subject to tuning"
+
+                    "Average if individual types"
+    types isEmpty ifTrue:[
+        trustfullness := 1
+    ] ifFalse:[
+        trustfullness := (types inject:0 into:[:a :type|a + type trustfullness]) / types size.
+        trustfullness := trustfullness + (trustfullnessBonus ? 0).
+    ].
+
+    "Created: / 17-05-2012 / 19:22:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !SmallSenseUnionType methodsFor:'testing'!
 
 isUnionType
@@ -141,5 +215,5 @@
 !SmallSenseUnionType class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseUnionType.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseUnionType.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
--- a/smallsense/SmallSenseUnknownType.st	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/SmallSenseUnknownType.st	Fri May 18 00:16:11 2012 +0100
@@ -42,6 +42,23 @@
     ^ theOneAndOnlyInstance.
 ! !
 
+!SmallSenseUnknownType methodsFor:'accessing'!
+
+trustfullness
+    "Return an integer value in <1..100>, higher value
+     means the object is more likely of that type."
+
+    ^ 1
+
+    "Modified: / 17-05-2012 / 19:20:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+trustfullness: anInteger
+    "Nothing to do here"
+
+    "Created: / 17-05-2012 / 19:44:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
 !SmallSenseUnknownType methodsFor:'comparing'!
 
 = another
@@ -117,5 +134,5 @@
 !SmallSenseUnknownType class methodsFor:'documentation'!
 
 version_SVN
-    ^ '$Id: SmallSenseUnknownType.st 7841 2011-12-16 12:43:56Z vranyj1 $'
+    ^ '$Id: SmallSenseUnknownType.st 8000 2012-05-17 23:16:11Z vranyj1 $'
 ! !
--- a/smallsense/smallsense.rc	Fri May 18 00:13:53 2012 +0100
+++ b/smallsense/smallsense.rc	Fri May 18 00:16:11 2012 +0100
@@ -25,7 +25,7 @@
       VALUE "LegalCopyright", "Copyright Claus Gittinger 1988-2011\nCopyright eXept Software AG 1998-2011\0"
       VALUE "ProductName", "Smalltalk/X\0"
       VALUE "ProductVersion", "6.2.1.1\0"
-      VALUE "ProductDate", "Sat, 21 Apr 2012 08:37:43 GMT\0"
+      VALUE "ProductDate", "Thu, 17 May 2012 23:18:49 GMT\0"
     END
 
   END
hg/stx-libtool