1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey
; The information about a primitive operation.
(define-record-type primop
(id ; Symbol identifying this primop
trivial? ; #t if this primop has does not require a continuation
side-effects ; side-effects of this primop
simplify-call-proc ; Simplify method
primop-cost-proc ; Cost of executing this operation
; (in some undisclosed metric)
return-type-proc ; Give the return type (for trivial primops only)
proc-data ; Record containing more data for the procedure primops
cond-data ; Record containing more data for conditional primops
)
(code-data ; Code generation data
))
(define-record-discloser type/primop
(lambda (primop)
(list 'primop (object-hash primop) (primop-id primop))))
(define all-primops (make-vector primop-count))
(define (make-primop id trivial? side-effects simplify cost type)
(let ((enum (name->enumerand id primop))
(primop (primop-maker id trivial? side-effects simplify cost type #f #f)))
(if enum
(vector-set! all-primops enum primop))
primop))
(define (get-primop enum)
(vector-ref all-primops enum))
(define-local-syntax (define-primop-method id args)
`(define (,id . ,args)
((,(concatenate-symbol 'primop- id '- 'proc) (call-primop ,(car args)))
. ,args)))
(define-primop-method primop-cost (call))
(define-primop-method simplify-call (call))
(define (trivial-call-return-type call)
((primop-return-type-proc (call-primop call)) call))
;-------------------------------------------------------------------------------
; procedure primops
(define-subrecord primop primop-proc-data primop-proc-data
(call-index ; index of argument being called
)
())
(define (primop-procedure? primop)
(if (primop-proc-data primop) #t #f))
; (call <cont> <proc-var> . <args>)
; (tail-call <cont-var> <proc-var> . <args>)
; (return <proc-var> . <args>)
; (jump <proc-var> . <args>)
; (throw <proc-var> . <args>)
;
; (unknown-call <cont> <proc-var> . <args>)
; (unknown-tail-call <cont-var> <proc-var> . <args>)
; (unknown-return <proc-var> . <args>)
(define (make-proc-primop id side-effects simplify cost index)
(let* ((enum (name->enumerand id primop))
(data (primop-proc-data-maker index))
(primop (primop-maker id #f side-effects simplify cost #f data #f)))
(vector-set! all-primops enum primop)
primop))
;-------------------------------------------------------------------------------
; conditional primops
(define-subrecord primop primop-cond-data primop-cond-data
(expand-to-conditional-proc ; Expand this call to a conditional
simplify-conditional?-proc ; Can this conditional be simplified
)
())
(define-primop-method expand-to-conditional (call))
(define-primop-method simplify-conditional? (call index value))
(define (primop-conditional? primop)
(if (primop-cond-data primop) #t #f))
(define (make-conditional-primop id side-effects simplify cost expand simplify?)
(let* ((enum (name->enumerand id primop))
(data (primop-cond-data-maker expand simplify?))
(primop (primop-maker id #f side-effects simplify cost #f #f data)))
(if enum (vector-set! all-primops enum primop))
primop))
;-------------------------------------------------------------------------------
; Random constants for location calls:
; ($CONTENTS <thing> <type> <offset> <rep>)
; ($SET-CONTENTS <cont> <thing> <type> <offset> <rep> <value>)
; 0 1 2 3 4
(define loc/owner 0)
(define loc/type 1)
(define loc/rep 2)
(define set/owner 1)
(define set/type 2)
(define set/rep 3)
(define set/value 4)
; For slots that do not contain code pointers:
; ($CLOSURE <cont> <env> <slot>)
; ($SET-CLOSURE <cont> <env> <slot> <value>)
; For slots that do contain code pointers:
; ($MAKE-PROCEDURE <cont> <env> <slot>)
; ($SET-CODE <cont> <env> <slot> <value>)
; For known calls to slots that contain code pointers:
; ($ENV-ADJUST <cont> <env> <slot>)
; 0 1 2
(define env/owner 0)
(define env/offset 1)
(define env/value 2)
|
