author  Tony GarnockJones <tonygarnockjones@gmail.com> 
Sun, 22 Jul 2018 14:00:04 +0100  
changeset 409  f19c9ff9d0d3 
parent 408  aa5e38d54ab0 
child 410  7e5d9e957c2f 
permissions  rwrr 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

1 
#lang racket/gui 
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

2 
;; Loader for images (version 1 format) from Russell Allen's 2015 
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

3 
;; variant of SmallWorld, a Tim Buddauthored Little Smalltalk 
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

4 
;; descendant. 
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

5 

369
3e1f84e6289d
Image saving
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset

6 
(require racket/bytes) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

7 
(require (onlyin sha bytes>hexstring)) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

8 
(require "objectmemory.rkt") 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

9 
(require "primitives.rkt") 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

10 

d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

11 
(definelogger vm) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

12 
(definelogger vm/jit) 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

13 

396
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

14 
(define picentrycount 3) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

15 
(define (pic) (vector #f #f #f #f #f #f)) ;; picentrycount times two  one each for class & method 
395
3979401d44c1
Introduce struct mic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
394
diff
changeset

16 

403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

17 
(struct jitVM VM (cache imagefilename) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

18 
#:methods gen:vmcallback 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

19 
[(define (vmblockcallback vm action) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

20 
;; Runs action in a new thread 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

21 
(lambda args 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

22 
(thread (match action 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

23 
[(unffiv blockproc) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

24 
(lambda () (apply blockproc vm (outermostk vm) args))] 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

25 
[_ 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

26 
(block>thunk vm action args)]))))]) 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

27 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

28 
(struct compilationresult (litmap [piccount #:mutable])) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

29 
(struct compilation (depth vm receiverclass method argnames labels state)) 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

30 

376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

31 
(define (buildjitcontext vm previouscontext args method ip stacktop temporaries stack) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

32 
(define maxstack (slotAt method 3)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

33 
(mkobj (VMContext vm) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

34 
method 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

35 
(obj (VMArray vm) args) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

36 
(obj (VMArray vm) temporaries) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

37 
(obj (VMArray vm) (vectorappend stack (makevector ( maxstack (vectorlength stack)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

38 
(VMnil vm)))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

39 
ip 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

40 
stacktop 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

41 
previouscontext)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

42 

6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

43 
(define (selectorstringarity str) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

44 
(define coloncount (for/sum [(c str)] (if (eqv? c #\:) 1 0))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

45 
(cond [(positive? coloncount) (+ coloncount 1)] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

46 
[(charalphabetic? (stringref str 0)) 1] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

47 
[else 2])) ;; assume binary operator 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

48 

6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

49 
(definenamespaceanchor nsanchor) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

50 
(define ns (namespaceanchor>namespace nsanchor)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

51 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

52 
(define (mksym fmt . args) (string>symbol (apply format fmt args))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

53 

dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

54 
(definesyntax let@ 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

55 
(syntaxrules () 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

56 
[(_ [n ncodeexp] bodycodeexp) 
406
3a84d16cac19
Remove gratuitous layer of gensym
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
405
diff
changeset

57 
(let@ [n 'n ncodeexp] bodycodeexp)] 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

58 
[(_ [n nexp ncodeexp] bodycodeexp) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

59 
(let ((n (gensym nexp))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

60 
`(let ((,n ,ncodeexp)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

61 
,bodycodeexp))])) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

62 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

63 
(define (compilation* depth compiletimevm receiverclass method state) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

64 
(define selector (slotAt method 0)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

65 
(define arity (selectorstringarity (bv>string selector))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

66 
(define literals (slotAt method 2)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

67 

6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

68 
(logvm/jitinfo 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

69 
"Compiling ~v defined in ~v, to be run in ~v (depth ~a), arity ~a, literals ~a, bytecode ~a, text:\n\n~a\n" 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

70 
(bv>string selector) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

71 
(slotAt method 5) 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

72 
receiverclass 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

73 
depth 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

74 
arity 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

75 
literals 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

76 
(bytes>hexstring (bvbytes (slotAt method 1))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

77 
(bv>string (slotAt method 6))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

78 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

79 
(define litmap (compilationresultlitmap state)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

80 
(for [(lit (objslots literals))] (genlit* litmap lit)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

81 

376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

82 
(define argnames (for/vector [(i arity)] (if (zero? i) 'self (mksym "arg~a" ( i 1))))) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

83 
(compilation depth 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

84 
compiletimevm 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

85 
receiverclass 
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

86 
method 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

87 
argnames 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

88 
(makehash) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

89 
state)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

90 

aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

91 
(define (topcompilation vm receiverclass method) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

92 
(compilation* 0 vm receiverclass method (compilationresult (makehasheq) 0))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

93 

aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

94 
(define (inlinecompilation c method) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

95 
(matchdefine (compilation depth vm receiverclass _method _argnames _labels state) c) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

96 
(compilation* (+ depth 1) vm receiverclass method state)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

97 

aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

98 
(define (genlit* litmap lit) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

99 
(hashref! litmap lit (lambda () 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

100 
(define n (hashcount litmap)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

101 
(if (bv? lit) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

102 
(mksym "lit~a~a" n (bv>string lit)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

103 
(mksym "lit~a" n))))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

104 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

105 
(define (genjumptolabel c ip stack) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

106 
(define labels (compilationlabels c)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

107 
(when (not (hashhaskey? labels ip)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

108 
(hashset! labels ip 'placeholder) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

109 
(define actuallabel 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

110 
(let ((newstack (for/list [(i (length stack))] (mksym "stack~a" i)))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

111 
`(lambda (k ,@newstack) ,(gencode c ip newstack)))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

112 
(hashset! labels ip actuallabel)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

113 
`(,(mksym "label~a" ip) k ,@stack)) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

114 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

115 
(define (genbuildjitcontext c ip stack) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

116 
`(buildjitcontext vm 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

117 
(k) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

118 
(vector ,@(vector>list (compilationargnames c))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

119 
method 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

120 
,ip 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

121 
,(length stack) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

122 
temporaries 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

123 
(vector ,@(reverse stack)))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

124 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

125 
(define (gensendk c ip stack) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

126 
(define result (gensym 'result)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

127 
`(caselambda [() ,(genbuildjitcontext c ip stack)] 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

128 
[(,result) ,(genjumptolabel c ip (cons result stack))])) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

129 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

130 
(define (genfreshtemps method) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

131 
(match (slotAt method 4) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

132 
[0 `'#()] 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

133 
[tempcount `(makevector ,tempcount NIL)])) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

134 

aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

135 
(define (gensend c classexp namebytes selectorexp kexp argexps) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

136 
(define picindex (compilationresultpiccount (compilationstate c))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

137 
(setcompilationresultpiccount! (compilationstate c) (+ picindex 1)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

138 
(define m (mksym "pic~a" picindex)) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

139 
(match classexp 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

140 
[`(objclass* vm self) #:when (< (compilationdepth c) 2) ;; self send 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

141 
(define receiverclass (compilationreceiverclass c)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

142 
(define method (lookupmethod (compilationvm c) receiverclass namebytes)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

143 
(define definingclass (slotAt method 5)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

144 
(loginfo "Selfsend of ~a to class ~a" namebytes receiverclass) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

145 
(define ic (inlinecompilation c method)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

146 
(define bodycode (genjumptolabel ic 0 '())) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

147 
(define litmap (compilationresultlitmap (compilationstate ic))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

148 
(define innercode 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

149 
`(let ((k ,kexp) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

150 
(method ,(genlit* litmap method)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

151 
(super ,(genlit* litmap (slotAt definingclass 1)))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

152 
(let ,(for/list [(formal (vector>list (compilationargnames ic))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

153 
(actual (inlist argexps))] 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

154 
`(,formal ,actual)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

155 
(let ((outerk k) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

156 
(temporaries ,(genfreshtemps method))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

157 
,(genlabeldefinitions ic bodycode))))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

158 
(logvminfo "INLINED:\n~a" (prettyformat innercode)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

159 
innercode] 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

160 
[_ 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

161 
`((lookupmessage/jit vm ,m ,classexp ,selectorexp) vm ,kexp ,@argexps)])) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

162 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

163 
(define (genblock c argumentlocation ip) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

164 
(define tempcount (slotAt (compilationmethod c) 4)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

165 
`(lambda (vm k . blockarguments) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

166 
,(let loop ((i argumentlocation)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

167 
(if (>= i tempcount) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

168 
`(void) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

169 
`(when (pair? blockarguments) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

170 
(vectorset! temporaries ,i (car blockarguments)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

171 
(let ((blockarguments (cdr blockarguments))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

172 
,(loop (+ i 1)))))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

173 
,(gencode c ip '()))) 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

174 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

175 
(define (compilationlitname c literal) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

176 
(hashref (compilationresultlitmap (compilationstate c)) literal)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

177 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

178 
(define (gencode c ip stack) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

179 
(define method (compilationmethod c)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

180 
(define bytecode (bvbytes (slotAt method 1))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

181 
(define literals (slotAt method 2)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

182 
(let translate ((ip ip) (stack stack)) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

183 
(define (nextbyte!) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

184 
(begin0 (bytesref bytecode ip) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

185 
(set! ip (+ ip 1)))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

186 
(define (decode!) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

187 
(define byte (nextbyte!)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

188 
(define low (bitwiseand byte #x0f)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

189 
(define high (bitwiseand (arithmeticshift byte 4) #x0f)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

190 
(if (zero? high) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

191 
(values low (nextbyte!)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

192 
(values high low))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

193 
(define ip0 ip) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

194 
(definevalues (opcode arg) (decode!)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

195 
(logvm/jitdebug " ~a: ~a ~a" ip0 opcode arg) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

196 
(match opcode 
386
552736e4616c
Preserve abstraction (!)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
385
diff
changeset

197 
[1 (let@ [n (mksym "slot~a_" arg) `(slotAt self ,arg)] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

198 
(translate ip (cons n stack)))] 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

199 
[2 (translate ip (cons (vectorref (compilationargnames c) arg) stack))] 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

200 
[3 (let@ [n (mksym "tmp~a_" arg) `(vectorref temporaries ,arg)] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

201 
(translate ip (cons n stack)))] 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

202 
[4 (let ((name (compilationlitname c (slotAt literals arg)))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

203 
(translate ip (cons name stack)))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

204 
[5 (match arg 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

205 
[(or 0 1 2 3 4 5 6 7 8 9) (translate ip (cons arg stack))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

206 
[10 (translate ip (cons `NIL stack))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

207 
[11 (translate ip (cons `TRUE stack))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

208 
[12 (translate ip (cons `FALSE stack))])] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

209 
[6 `(begin (slotAtPut self ,arg ,(car stack)) ,(translate ip stack))] 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

210 
[7 `(begin (vectorset! temporaries ,arg ,(car stack)) ,(translate ip stack))] 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

211 
[8 (let* ((argcount arg) 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

212 
(args (reverse (take stack argcount))) 
387
9af7f893128d
Factor out gensend
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
386
diff
changeset

213 
(stack (drop stack argcount))) 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

214 
(definevalues (selectorliteralindex classexp) 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

215 
(match/values (decode!) 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

216 
[(9 selectorliteralindex) 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

217 
(values selectorliteralindex `(objclass* vm ,(car args)))] 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

218 
[(15 11) 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

219 
(values (nextbyte!) `super)])) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

220 
(define k (gensendk c ip stack)) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

221 
(define selector (slotAt literals selectorliteralindex)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

222 
(define selectorexp (compilationlitname c selector)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

223 
(gensend c classexp (bvbytes selector) selectorexp k args))] 
389
befaa2a55f7b
Clean out comments & obsoleted code
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
388
diff
changeset

224 
;; 9 inlined in the processing of bytecode 8 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

225 
[10 (match arg 
385
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

226 
[0 (let@ [isNil `(boolean>obj vm (eq? NIL ,(car stack)))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

227 
(translate ip (cons isNil (cdr stack))))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

228 
[1 (let@ [notNil `(boolean>obj vm (not (eq? NIL ,(car stack))))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

229 
(translate ip (cons notNil (cdr stack))))])] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

230 
[11 (match stack 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

231 
[(list* j i stack) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

232 
(let@ [binopk (gensendk c ip stack)] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

233 
`(if (and (number? ,i) (number? ,j)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

234 
,(match arg 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

235 
[0 `(,binopk (boolean>obj vm (< ,i ,j)))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

236 
[1 `(,binopk (boolean>obj vm (<= ,i ,j)))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

237 
[2 `(,binopk (+ ,i ,j))]) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

238 
,(let ((namebytes (match arg [0 #"<"] [1 #"<="] [2 #"+"]))) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

239 
(gensend c 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

240 
`(objclass* vm ,i) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

241 
namebytes 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

242 
`(mkbv NIL ,namebytes) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

243 
binopk 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

244 
(list i j)))))])] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

245 
[12 (let ((target (nextbyte!))) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

246 
(let@ [block `(mkffiv BLOCK ,(genblock c arg ip))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

247 
(translate target (cons block stack))))] 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

248 
[13 (define primitivenumber (nextbyte!)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

249 
(match primitivenumber 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

250 
[8 (let ((v (gensym 'blockresult)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

251 
(block (car stack)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

252 
(argc ( arg 1)) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

253 
(stack (cdr stack))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

254 
`(match ,block 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

255 
[(unffiv blockproc) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

256 
(blockproc vm 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

257 
;; TODO vvv : use caselambda to translate the context chain 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

258 
k ;; not (lambda (,v) ,(translate ip (cons v (drop stack argc)))) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

259 
;; ^ reason being the image BUGGILY (?!?) relies on primitive 8 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

260 
;; immediately returning to the surrounding context!! 
377
8accd6d3f51d
Extract and make use of block>thunk, to support imageproduced block calls.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset

261 
,@(reverse (take stack argc)))] 
8accd6d3f51d
Extract and make use of block>thunk, to support imageproduced block calls.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset

262 
[(obj (== BLOCK) _) 
8accd6d3f51d
Extract and make use of block>thunk, to support imageproduced block calls.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset

263 
(k ((block>thunk vm ,block (list ,@(reverse (take stack argc))))))]))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

264 
[34 'NIL] 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

265 
[35 (let@ [ctxref (genbuildjitcontext c ip stack)] 
385
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

266 
(translate ip (cons ctxref stack)))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

267 
[36 (let@ [arr `(mkobj ARRAY ,@(reverse (take stack arg)))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

268 
(translate ip (cons arr (drop stack arg))))] 
388  269 
[_ (let ((generator (hashref *primitivecodesnippets* 
270 
primitivenumber 

405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

271 
(lambda () (error 'gencode 
388  272 
"Unknown primitive: ~a" 
273 
primitivenumber))))) 

274 
(let@ [primresult (generator 'vm (reverse (take stack arg)))] 

275 
(translate ip (cons primresult (drop stack arg)))))])] 

385
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

276 
[14 (let@ [clsvar `(slotAt (objclass* vm self) ,(+ arg 5))] 
0d3839af02db
Tighten let@ definition
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
383
diff
changeset

277 
(translate ip (cons clsvar stack)))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

278 
[15 (match arg 
378
2a35e7fcba59
Remove resumejitcontext
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset

279 
[1 `(k self)] 
2a35e7fcba59
Remove resumejitcontext
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset

280 
[2 `(k ,(car stack))] 
2a35e7fcba59
Remove resumejitcontext
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
377
diff
changeset

281 
[3 `(outerk ,(car stack))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

282 
[5 (translate ip (cdr stack))] 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

283 
[6 (genjumptolabel c (nextbyte!) stack)] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

284 
[7 (let ((target (nextbyte!))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

285 
(logvm/jitdebug "if ~a true jump to ~a, else continue at ~a" (car stack) target ip) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

286 
`(if (eq? ,(car stack) TRUE) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

287 
,(genjumptolabel c target (cdr stack)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

288 
,(genjumptolabel c ip (cdr stack))))] 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

289 
[8 (let ((target (nextbyte!))) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

290 
(logvm/jitdebug "if ~a false jump to ~a, else continue at ~a" (car stack) target ip) 
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

291 
`(if (eq? ,(car stack) FALSE) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

292 
,(genjumptolabel c target (cdr stack)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

293 
,(genjumptolabel c ip (cdr stack))))] 
389
befaa2a55f7b
Clean out comments & obsoleted code
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
388
diff
changeset

294 
;; 11 inlined in the processing of bytecode 8 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

295 
[_ (error 'gencode "Unhandled dospecial case ~v" arg)])] 
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

296 
[_ (error 'gencode "Method ~v  unhandled opcode ~v, arg ~v" 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

297 
(slotAt (compilationmethod c) 0) ;; selector 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

298 
opcode 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

299 
arg)]))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

300 

404
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

301 
(define (genlabeldefinitions c bodyexp) 
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

302 
`(letrec (,@(for/list [((ip label) (inhash (compilationlabels c)))] 
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

303 
`(,(mksym "label~a" ip) ,label))) 
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

304 
,bodyexp)) 
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

305 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

306 
(define (finishcompilation c compiletimevm innercode) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

307 
(define litmaplist (hash>list (compilationresultlitmap (compilationstate c)))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

308 
(define code 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

309 
`(lambda (method super NIL TRUE FALSE ARRAY BLOCK ,@(map cdr litmaplist)) 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

310 
,@(for/list [(i (compilationresultpiccount (compilationstate c)))] 
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

311 
`(define ,(mksym "pic~a" i) (pic))) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

312 
,innercode)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

313 

408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

314 
(logvm/jitinfo "Resulting code:\n~a" (prettyformat code)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

315 
(define literals (slotAt (compilationmethod c) 2)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

316 
(define definingclass (slotAt (compilationmethod c) 5)) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

317 
(apply (eval code ns) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

318 
(compilationmethod c) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

319 
(slotAt definingclass 1) ;; defining class's superclass 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

320 
(VMnil compiletimevm) ;; assuming this VM is the one that will be used at call time! 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

321 
(VMtrue compiletimevm) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

322 
(VMfalse compiletimevm) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

323 
(VMArray compiletimevm) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

324 
(VMBlock compiletimevm) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

325 
(map car litmaplist))) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

326 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

327 
(define (compileblockproc compiletimevm 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

328 
method 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

329 
outerargs 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

330 
actualtemporaries 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

331 
argumentlocation 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

332 
initialip) 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

333 
(define class (objclass* compiletimevm (car outerargs))) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

334 
(define c (topcompilation compiletimevm class method)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

335 
(define bodycode (genblock c argumentlocation initialip)) ;; imperative! 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

336 
(define innercode 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

337 
`(lambda (temporaries ,@(vector>list (compilationargnames c))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

338 
(let ((outerk (outermostk vm))) 
404
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

339 
,(genlabeldefinitions c bodycode)))) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

340 
(apply (finishcompilation c compiletimevm innercode) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

341 
actualtemporaries 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

342 
outerargs)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

343 

405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

344 
(define (compilemethodproc compiletimevm class method) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

345 
(define c (topcompilation compiletimevm class method)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

346 
(define bodycode (genjumptolabel c 0 '())) ;; imperative! 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

347 
(define innercode 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

348 
`(lambda (vm k ,@(vector>list (compilationargnames c))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

349 
(let ((outerk k) 
408
aa5e38d54ab0
Inline self sends  a kind of method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
406
diff
changeset

350 
(temporaries ,(genfreshtemps method))) 
404
158def14bb15
Pull out genlabeldefinitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
403
diff
changeset

351 
,(genlabeldefinitions c bodycode)))) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

352 
(finishcompilation c compiletimevm innercode)) 
376
6944f882b052
First measurable JIT for SmallWorld. Much obvious inefficiency remains to be removed
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
375
diff
changeset

353 

392
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset

354 
(define (lookupmethod/cache vm class namebytes) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

355 
(define classcache (hashref! (jitVMcache vm) class makeweakhash)) 
402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

356 
(hashref! classcache 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

357 
namebytes 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

358 
(lambda () 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

359 
(define m (lookupmethod vm class namebytes)) 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

360 
(and m (compilemethodproc vm class m))))) 
368
bd33c8691bba
Simplest possible method cache. hop: 411861 bytecodes/sec; 65707 sends/sec > 859845 bytecodes/sec; 106388 sends/sec
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
367
diff
changeset

361 

396
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

362 
(define (lookupmessage/jit vm pic class selector) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

363 
(let searchpic ((slotindex 0)) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

364 
(define thisclass (vectorref pic (* slotindex 2))) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

365 
(if (eq? thisclass class) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

366 
(vectorref pic (+ (* slotindex 2) 1)) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

367 
(let* ((nextslotindex (+ slotindex 1)) 
409
f19c9ff9d0d3
Repair pic fillin code: it had been filling in only the final slot (!). ~7% speed boost
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
408
diff
changeset

368 
(moreslotstocheck? (and thisclass (< nextslotindex picentrycount)))) 
396
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

369 
(if moreslotstocheck? 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

370 
(searchpic nextslotindex) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

371 
(let ((method (lookupmethod/cache vm class (bvbytes selector)))) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

372 
(if (not method) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

373 
(lambda (vm ctx . args) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

374 
(senddnu vm ctx (obj (VMArray vm) (list>vector args)) class selector)) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

375 
(let ((slotempty? (not thisclass))) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

376 
(when slotempty? 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

377 
(vectorset! pic (* slotindex 2) class) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

378 
(vectorset! pic (+ (* slotindex 2) 1) method)) 
3bfb9afdbd9d
Switch from mic to pic
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
395
diff
changeset

379 
method)))))))) 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

380 

e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

381 
(define (senddnu vm ctx arguments class selector) 
392
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset

382 
(define dnunamebytes #"doesNotUnderstand:") 
618244a1ee07
Small change toward avoiding consing selectors unnecessarily.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
389
diff
changeset

383 
(match (lookupmethod/cache vm class dnunamebytes) 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

384 
[#f (error 'sendmessage* "Unhandled selector ~a at class ~a" selector class)] 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

385 
[dnumethod 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

386 
(logvmwarning "DNU  arguments ~a class ~a selector ~a" arguments class selector) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

387 
(dnumethod vm ctx (slotAt arguments 0) (mkobj (VMArray vm) selector arguments))])) 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

388 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

389 
(define (block>thunk vm block args) ;; Expects a real bytecode block, not an ffiv one 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

390 
(lambda () 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

391 
(define method (slotAt block 0)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

392 
(define outerargs (vector>list (objslots (slotAt block 1)))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

393 
(define temporaries (objslots (slotAt block 2))) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

394 
(define argumentlocation (slotAt block 7)) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

395 
(define blockip (slotAt block 9)) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

396 
(define f (compileblockproc vm method outerargs temporaries argumentlocation blockip)) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

397 
(apply f vm (outermostk vm) args))) 
353
d4161a4117e8
Image loader and virtual machine for SmallWorld 2015 Smalltalk.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
diff
changeset

398 

402
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

399 
(define (outermostk vm) 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

400 
(caselambda [() (VMnil vm)] 
dc1bd2065cd1
Remove interpreter; refactor compiler to support block entry points (not needed by current image)
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
396
diff
changeset

401 
[(result) result])) 
377
8accd6d3f51d
Extract and make use of block>thunk, to support imageproduced block calls.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
376
diff
changeset

402 

379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

403 
;;=========================================================================== 
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset

404 

379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

405 
(defineprimitive vm [6 innerctx] ;; "new context execute" 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

406 
(when (not (zero? (slotAt innerctx 5))) (error 'execute "Cannot execute from nonempty stack")) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

407 
(when (not (zero? (slotAt innerctx 4))) (error 'execute "Cannot execute from nonzero IP")) 
405
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

408 
(define args (slotAt innerctx 1)) 
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

409 
(define f (compilemethodproc vm (objclass* vm (slotAt args 0)) (slotAt innerctx 0))) 
5a019affe985
Plumbing preparation for method customization
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
404
diff
changeset

410 
(apply f vm (outermostk vm) (vector>list (objslots args)))) 
379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

411 

e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

412 
(defineprimitive vm [116] 
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

413 
(let ((imagebytes (serializeimage vm))) 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

414 
(displaytofile imagebytes (jitVMimagefilename vm) #:exists 'replace))) 
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset

415 

379
e5e063ac93ef
Proper direct sends (and MICs); inline primitive definitions
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
378
diff
changeset

416 
;;=========================================================================== 
375
c090edeff4c5
Split out most primitives into a separate routine.
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
373
diff
changeset

417 

369
3e1f84e6289d
Image saving
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
368
diff
changeset

418 
(let* ((imagefilename "SmallWorld/src/image") 
403
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

419 
(vm (callwithinputfile imagefilename 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

420 
(lambda (fh) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

421 
(readimage fh jitVM (list (makeweakhasheq) imagefilename)))))) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

422 
(bootimage vm 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

423 
(lambda (vm source) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

424 
((lookupmethod/cache vm (objclass source) #"doIt") vm (outermostk vm) source)) 
5e81df1d79c4
Factor out objectmemory.rkt and primitives.rkt
Tony GarnockJones <tonygarnockjones@gmail.com>
parents:
402
diff
changeset

425 
(currentcommandlinearguments))) 