1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
4
5; This is the main entry point to the compiler.  It returns a template
6; that will execute the forms (each of which is a node).
7;
8; This is written in a somewhat odd fashion to make sure that the forms are
9; not retained once they have been compiled.
10
11(define (compile-forms forms name package-key)
12  (with-package-key package-key
13    (lambda ()
14      (if (null? forms)
15	  (segment->template (sequentially
16			      (lambda-protocol 0 #t #f #f)
17			      (deliver-value (instruction (enum op unspecific))
18					     (return-cont #f)))
19			     (make-frame #f name 0 #f #f #f))
20	  (compile-forms-loop (reverse forms)
21			      name
22			      #f)))))			;next template
23
24(define (compile-forms-loop forms name next)
25  (if (null? forms)
26      next
27      (compile-forms-loop (cdr forms)
28			  name
29			  (compile-form (car forms) name next))))
30
31; Compile a single top-level form, returning a template.  NEXT is either #F or
32; a template; if it is a template we jump to it after FORM.
33; Stack has zero args, no env, template.
34
35(define (compile-form form name next)
36  (let ((frame (make-frame #f name 0 #t #f #f)))
37    (segment->template
38      (sequentially
39        (lambda-protocol 0 #t #f #f)	; template, no env, no closure
40	(let ((node (flatten-form (force-node form))))
41	  (cond ((define-node? node)
42		 (sequentially
43		   (compile-definition node frame an-ignore-values-cont)
44		   (if next
45		       (call-template-inst next #f 0 1 frame)
46		       (instruction (enum op values) 0 0))))
47		(next
48		 (sequentially
49		   (compile-expression node 1 frame an-ignore-values-cont)
50		   (call-template-inst next #f 0 1 frame)))
51		(else
52		 (compile-expression node 1 frame (return-cont #f))))))
53      frame)))
54
55(define (call-template-inst template label nargs depth frame)
56  (let ((offset (template-offset frame depth))
57	(index (literal->index frame template)))
58    (using-optional-label (enum op call-template)
59			  label
60			  (high-byte offset)
61			  (low-byte offset)
62			  (high-byte index)
63			  (low-byte index)
64			  nargs)))
65
66(define (template-call template depth frame cont)
67  (receive (before depth label after)
68      (push-continuation depth frame cont #f)
69    (sequentially before
70		  (call-template-inst template label 0 depth frame)
71		  after)))
72
73; Definitions must be treated differently from assignments: we must
74; use STORED-OBJECT-SET! instead of SET-GLOBAL! because the SET-GLOBAL!
75; instruction traps if an attempt is made to store into an undefined
76; location.
77;
78; Called with a stack depth of one (the template).
79
80(define (compile-definition node frame cont)
81  (let* ((form (node-form node))
82	 (name (cadr form)))
83    (sequentially (stack-indirect-instruction
84		    (template-offset frame 1)
85		    (binding->index frame
86				    (node-ref name 'binding)
87				    (node-form name)
88				    #f))
89		  (begin (depth-check! frame 2)
90			 (instruction (enum op push)))
91		  (compile-expression (caddr form)
92				      2			; stack depth
93				      frame
94				      (named-cont (node-form name)))
95		  (deliver-value
96		   (instruction (enum op stored-object-set!)
97				(enum stob location)
98				location-contents-offset
99				0)	; do not log in current proposal
100		   cont))))
101
102(define location-contents-offset
103  (cond ((assq 'location stob-data)
104	 => (lambda (stuff)
105	      (let loop ((slots (cdddr stuff)) (i 0))
106		(if (eq? (caar slots) 'contents)
107		    i
108		    (loop (cdr slots) (+ i 1))))))
109	(else
110	 (assertion-violation 'location-contents-offset
111			      "can't find location data in STOB-DATA"))))
112
113;----------------
114; Make a startup procedure from a list of initialization templates.  This
115; is only used by the static linker.  RESUMER should be a template that
116; returns a procedure that takes 8 arguments (the number the VM passes to
117; the startup procedure).
118
119; The length of the argument list needs to be in sync with
120; MAKE-USUAL-RESUMER in rts/init.scm, and S48-CALL-STARTUP-PROCEDURE
121; in vm/interp/resume.scm.
122
123(define (make-startup-procedure inits resumer)
124  (let* ((nargs 8)
125	 (frame (make-frame #f		; no parent
126			    #f		; no name
127			    nargs	; args on stack
128			    #t		; keep template
129			    #f		; drop environment
130			    #f)))       ; drop closure
131    (append-templates inits
132		      nargs
133		      frame
134		      (sequentially
135		        (template-call resumer
136				       (+ nargs 1)	; args + template
137				       frame
138				       (fall-through-cont #f #f))
139			(instruction (enum op pop-n) 0 1) ; remove template
140			(instruction (enum op tail-call) nargs 0 0)))))
141
142; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
143; and then calls template FINAL on the arguments.
144
145(define (append-templates templates nargs frame final)
146  (segment->template
147    (sequentially
148      (lambda-protocol nargs #t #f #f)	; push template
149      (reduce (lambda (template seg)
150		(sequentially
151		  (template-call template
152				 (+ nargs 1)		; arguments + template
153				 frame
154				 an-ignore-values-cont)
155		  seg))
156	      final
157	      templates))
158    frame))
159
160(define an-ignore-values-cont (ignore-values-cont #f #f))
161
162