1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Assembler Top Level
28;;; package: (compiler assembler)
29
30(declare (usual-integrations))
31
32(define *equates*)
33(define *objects*)
34(define *entry-points*)
35(define *the-symbol-table*)
36(define *start-label*)
37(define *end-label*)
38
39;;;; Assembler top level procedure
40
41(define (assemble start-label instructions)
42  (fluid-let ((*equates* (make-queue))
43	      (*objects* (make-queue))
44	      (*entry-points* (make-queue))
45	      (*the-symbol-table* (make-symbol-table))
46	      (*start-label* start-label)
47	      (*end-label* (generate-uninterned-symbol 'END-LABEL-)))
48    (initialize-symbol-table!)
49    (call-with-values
50	(lambda ()
51	  (initial-phase
52	   (if (null? instructions)
53	       '()
54	       (let ((holder (list 'HOLDER)))
55		 (let loop ((tail holder)
56			    (instructions
57			     (let ((i instructions))
58			       (set! instructions)
59			       i)))
60		   (if (not (null? instructions))
61		       (let ((first (car instructions)))
62			 (if (and (pair? first)
63				  (eq? (car first) 'COMMENT))
64			     (loop tail (cdr instructions))
65			     (begin
66			       (set-cdr! tail
67					 (lap:syntax-instruction first))
68			       (loop (last-pair tail) (cdr instructions)))))))
69		 (cdr holder)))))
70      (lambda (directives vars)
71	(let* ((count (relax! directives vars))
72	       (block (assemble-objects (final-phase directives))))
73	  (values count
74		  block
75		  (queue->list *entry-points*)
76		  (symbol-table->assq-list *the-symbol-table*)))))))
77
78(define (relax! directives vars)
79  (define (continue widening? count)
80    (clear-symbol-table!)
81    (initialize-symbol-table!)
82    (loop widening?
83	  (phase-1 widening? directives)
84	  (1+ count)))
85
86  (define (loop widening? vars count)
87    (finish-symbol-table!)
88    (if (null? vars)
89	count
90	(call-with-values (lambda () (phase-2 widening? vars))
91	  (lambda (any-modified? number-of-vars)
92	    (cond (any-modified?
93		   (continue false count))
94		  ((zero? number-of-vars)
95		   count)
96		  (else
97		   (continue (not widening?) count)))))))
98  (loop false vars 0))
99
100;;; Vector header and NMV header for code section
101
102(define compiler-output-block-number-of-header-words 2)
103
104(define starting-pc
105  (* compiler-output-block-number-of-header-words scheme-object-width))
106
107;;;; Output block generation
108
109(define (final-phase directives)
110  ;; Convert label values to integers:
111  (for-each (lambda (pair)
112	      (set-binding-value!
113	       (cdr pair)
114	       (interval-final-value (binding-value (cdr pair)))))
115	    (symbol-table-bindings *the-symbol-table*))
116  (let ((code-block
117	 (bit-string-allocate (- (->bitstring-pc
118				  (symbol-table-value *the-symbol-table*
119						      *end-label*))
120				 starting-pc))))
121    (assemble-directives! code-block
122			  directives
123			  (instruction-initial-position code-block))
124    code-block))
125
126(define (assemble-objects code-block)
127  (let ((objects (map assemble-an-object (queue->list *objects*))))
128    (if compiler:cross-compiling?
129	(vector 'DEBUGGING-INFO-SLOT code-block objects scheme-object-width)
130	(let* ((bl (quotient (bit-string-length code-block)
131			     scheme-object-width))
132	       (non-pointer-length
133		((ucode-primitive make-non-pointer-object) bl))
134	       (objects-length (length objects))
135	       (total-length (fix:+ 1 (fix:+ objects-length bl)))
136	       (flo-length
137		(let ((flo-size (fix:quotient float-width scheme-datum-width)))
138		  (fix:quotient (fix:+ total-length (fix:- flo-size 1))
139				flo-size)))
140	       (output-block
141		(object-new-type (ucode-type compiled-code-block)
142				 (flo:vector-cons flo-length))))
143	  (with-absolutely-no-interrupts
144	    (lambda ()
145	      (let ((ob (object-new-type (ucode-type vector) output-block)))
146		(subvector-fill! ob
147				 (fix:+ bl 1)
148				 (system-vector-length ob)
149				 #f)
150		(vector-set! ob 0
151			     ((ucode-primitive primitive-object-set-type)
152			      (ucode-type manifest-nm-vector)
153			      non-pointer-length)))))
154	  (write-bits! output-block
155		       ;; After header just inserted.
156		       (* scheme-object-width 2)
157		       code-block)
158	  ((ucode-primitive primitive-object-set! 3)
159	   output-block 0
160	   (object-new-type (ucode-type manifest-vector) total-length))
161	  (insert-objects! output-block objects (fix:+ bl 1))
162	  output-block))))
163
164(define (assemble-an-object object)
165  (case (car object)
166    ((SCHEME-OBJECT)
167     ;; (SCHEME-OBJECT <deflabel> <object>)
168     (cdr object))
169    ((SCHEME-EVALUATION)
170     ;; (SCHEME-EVALUATION <deflabel> <offlabel>)
171     (list (cadr object) (evaluate (caddr object) false)))
172    (else
173     (error "assemble-an-object: Unknown kind"
174	    object))))
175
176(define (insert-objects! v objects where)
177  (cond ((not (null? objects))
178	 (system-vector-set! v where (cadar objects))
179	 (insert-objects! v (cdr objects) (fix:+ where 1)))
180	((not (fix:= where (system-vector-length v)))
181	 (error "insert-objects!: object phase error" where))
182	(else unspecific)))
183
184(define (assemble-directives! block directives initial-position)
185
186  (define (loop directives dir-stack pc pc-stack position last-blabel blabel)
187
188    (define (actual-bits bits l)
189      (instruction-insert! bits block position
190       (lambda (np)
191	 (declare (integrate np))
192	 (loop (cdr directives) dir-stack (+ pc l) pc-stack np
193	       last-blabel blabel))))
194
195    (define (block-offset offset last-blabel blabel)
196      (instruction-insert!
197       (block-offset->bit-string offset (eq? blabel *start-label*))
198       block position
199       (lambda (np)
200	 (declare (integrate np))
201	 (loop (cdr directives) dir-stack
202	       (+ pc block-offset-width)
203	       pc-stack np
204	       last-blabel blabel))))
205
206    (define (evaluation handler expression l)
207      (actual-bits (handler
208		    (evaluate expression
209			      (if (null? pc-stack)
210				  (->machine-pc pc)
211				  (car pc-stack))))
212		   l))
213
214    (define (end-assembly)
215      (cond ((not (null? dir-stack))
216	     (loop (car dir-stack) (cdr dir-stack) pc pc-stack position
217		   last-blabel blabel))
218	    ((not (= (abs (- position initial-position))
219		     (- pc starting-pc)))
220	     (error "assemble-directives!: phase error"
221		    `(PC ,starting-pc ,pc)
222		    `(BIT-POSITION ,initial-position ,position)))
223	    ((not (= (symbol-table-value *the-symbol-table* *end-label*)
224		     (->machine-pc (final-pad pc))))
225	     (error "assemble-directives!: phase error"
226		    `(LABEL ,*end-label*)
227		    `(ACTUAL-PC ,(->machine-pc (final-pad pc)))
228		    `(RESOLVED-PC ,(symbol-table-value
229				    *the-symbol-table*
230				    *end-label*))))
231	    (else
232	     (final-pad! block pc position))))
233
234    (if (null? directives)
235	(end-assembly)
236	(let ((this (car directives)))
237	  (case (vector-ref this 0)
238	    ((LABEL)
239	     (let* ((label (vector-ref this 1))
240		    (pcdef (symbol-table-value *the-symbol-table* label)))
241	       (if (not (= pcdef (->machine-pc pc)))
242		   (error "assemble-directives!: phase error"
243			  `(LABEL ,label)
244			  `(ACTUAL-PC ,pc)
245			  `(RESOLVED-PC ,pcdef))))
246	     (loop (cdr directives) dir-stack pc pc-stack position
247		   last-blabel blabel))
248	    ((TICK)
249	     (loop (cdr directives) dir-stack
250		   pc
251		   (if (vector-ref this 1)
252		       (cons (->machine-pc pc) pc-stack)
253		       (cdr pc-stack))
254		   position
255		   last-blabel blabel))
256	    ((FIXED-WIDTH-GROUP)
257	     (loop (vector-ref this 2) (cons (cdr directives) dir-stack)
258		   pc pc-stack
259		   position
260		   last-blabel blabel))
261	    ((CONSTANT)
262	     (let ((bs (vector-ref this 1)))
263	       (actual-bits bs (bit-string-length bs))))
264	    ((EVALUATION)
265	     (evaluation (vector-ref this 3)
266			 (vector-ref this 1)
267			 (vector-ref this 2)))
268	    ((VARIABLE-WIDTH-EXPRESSION)
269	     (let ((sel (car (vector-ref this 3))))
270	       (evaluation (variable-handler-wrapper (selector/handler sel))
271			   (vector-ref this 1)
272			   (selector/length sel))))
273	    ((BLOCK-OFFSET)
274	     (let* ((label (vector-ref this 1))
275		    (offset (evaluate `(- ,label ,blabel) '())))
276	       (if (> offset maximum-block-offset)
277		   (block-offset (evaluate `(- ,label ,last-blabel) '())
278				 label last-blabel)
279		   (block-offset offset label blabel))))
280	    ((PADDING)
281	     (let ((remdr (vector-ref this 1))
282		   (divsr (vector-ref this 2))
283		   (padding-string (vector-ref this 3)))
284	       (let* ((pc* (->bitstring-pc (paddify (->machine-pc pc)
285						    remdr divsr)))
286		      (pc-diff (- pc* pc))
287		      (padding-length (bit-string-length padding-string)))
288		 (if (not (zero? (remainder pc-diff padding-length)))
289		     (error "assemble-directives!: Bad padding"
290			    pc this)
291		     (actual-bits (replicate padding-string
292					     (quotient pc-diff padding-length))
293				  pc-diff)))))
294	    (else
295	     (error "assemble-directives!: Unknown directive" this))))))
296
297  (loop directives '() starting-pc '() initial-position
298	*start-label* *start-label*))
299
300;;;; Input conversion
301
302(define (initial-phase input)
303  (let ((directives (make-queue)))
304    (define (loop to-convert pcmin pcmax pc-stack group vars)
305      (define (collect-group!)
306	(if (not (null? group))
307	    (add-to-queue! directives
308			   (vector 'FIXED-WIDTH-GROUP
309				   (car group)
310				   (reverse! (cdr group))))))
311
312      (define (new-directive! dir)
313	(collect-group!)
314	(add-to-queue! directives dir))
315
316      (define (process-label! label)
317	(set-label-value! (cadr label) pcmin pcmax)
318	(new-directive! (list->vector label)))
319
320      (define (process-fixed-width directive width)
321	(loop (cdr to-convert)
322	      (+ width pcmin) (+ width pcmax) pc-stack
323	      (if (null? group)
324		  (cons width (list directive))
325		  (cons (+ width (car group))
326			(cons directive (cdr group))))
327	      vars))
328
329      (define (process-variable-width directive)
330	(new-directive! directive)
331	(call-with-values (lambda () (variable-width-lengths directive))
332	  (lambda (minl maxl)
333	    (loop (cdr to-convert)
334		  (+ pcmin minl) (+ pcmax maxl)
335		  pc-stack '()
336		  (cons directive vars)))))
337
338      (define (process-trivial-directive)
339	(loop (cdr to-convert)
340	      pcmin pcmax pc-stack
341	      group vars))
342
343      (if (null? to-convert)
344	  (let ((emin (final-pad pcmin))
345		(emax (+ pcmax maximum-padding-length)))
346	    (set-label-value! *end-label* emin emax)
347	    (collect-group!)
348	    (values (queue->list directives) vars))
349
350	  (let ((this (car to-convert)))
351	    (cond ((bit-string? this)
352		   (process-fixed-width (vector 'CONSTANT this)
353					(bit-string-length this)))
354		  ((not (pair? this))
355		   (error "initial-phase: Unknown directive" this))
356		  (else
357		   (case (car this)
358		     ((CONSTANT)
359		      (process-fixed-width (list->vector this)
360					   (bit-string-length (cadr this))))
361
362		     ((EVALUATION)
363		      (process-fixed-width (list->vector this)
364					   (caddr this)))
365
366		     ((VARIABLE-WIDTH-EXPRESSION)
367		      (process-variable-width
368		       (vector 'VARIABLE-WIDTH-EXPRESSION
369			       (cadr this)
370			       (if (null? pc-stack)
371				   (label->machine-interval pcmin pcmax)
372				   (car pc-stack))
373			       (map list->vector (cddr this)))))
374		     ((GROUP)
375		      (new-directive! (vector 'TICK true))
376		      (loop (append (cdr this)
377				    (cons '(TICK-OFF) (cdr to-convert)))
378			    pcmin pcmax
379			    (cons (label->machine-interval pcmin pcmax)
380				  pc-stack)
381			    '() vars))
382		     ((TICK-OFF)
383		      (new-directive! (vector 'TICK false))
384		      (loop (cdr to-convert) pcmin pcmax
385			    (cdr pc-stack) '() vars))
386		     ((LABEL)
387		      (process-label! this)
388		      (loop (cdr to-convert) pcmin pcmax pc-stack '() vars))
389		     ((BLOCK-OFFSET)
390		      (process-fixed-width (list->vector this)
391					   block-offset-width))
392		     ((EQUATE)
393		      (add-to-queue! *equates* (cdr this))
394		      (process-trivial-directive))
395		     ((SCHEME-OBJECT SCHEME-EVALUATION)
396		      (add-to-queue! *objects* this)
397		      (process-trivial-directive))
398		     ((ENTRY-POINT)
399		      (add-to-queue! *entry-points* (cadr this))
400		      (process-trivial-directive))
401		     ((PADDING)
402		      (let ((directive (->padding-directive this)))
403			(new-directive! directive)
404			(after-padding
405			 directive pcmin pcmax
406			 (lambda (pcmin pcmax)
407			   (loop (cdr to-convert) pcmin pcmax
408				 pc-stack '() vars)))))
409		     (else
410		      (error "initial-phase: Unknown directive" this))))))))
411    (loop input starting-pc starting-pc '() '() '())))
412
413(define (phase-1 widening? directives)
414  (define (loop rem pcmin pcmax pc-stack vars)
415    (if (null? rem)
416	(let* ((emin (final-pad pcmin))
417	       (emax (if (not widening?)
418			 (+ pcmax maximum-padding-length)
419			 emin)))
420	  (set-label-value! *end-label* emin emax)
421	  vars)
422	(let ((this (car rem)))
423	  (case (vector-ref this 0)
424	    ((LABEL)
425	     (set-label-value! (vector-ref this 1) pcmin pcmax)
426	     (loop (cdr rem) pcmin pcmax pc-stack vars))
427	    ((FIXED-WIDTH-GROUP)
428	     (let ((l (vector-ref this 1)))
429	       (loop (cdr rem)
430		     (+ pcmin l)
431		     (+ pcmax l)
432		     pc-stack
433		     vars)))
434	    ((VARIABLE-WIDTH-EXPRESSION)
435	     (vector-set! this 2
436			  (if (null? pc-stack)
437			      (label->machine-interval pcmin pcmax)
438			      (car pc-stack)))
439	     (call-with-values (lambda () (variable-width-lengths this))
440	       (lambda (minl maxl)
441		 (loop (cdr rem)
442		       (+ pcmin minl)
443		       (+ pcmax (if widening? minl maxl))
444		       pc-stack
445		       (cons this vars)))))
446	    ((TICK)
447	     (loop (cdr rem)
448		   pcmin pcmax
449		   (if (vector-ref this 1)
450		       (cons (label->machine-interval pcmin pcmax) pc-stack)
451		       (cdr pc-stack))
452		   vars))
453	    ((PADDING)
454	     (after-padding
455	      this pcmin pcmax
456	      (lambda (pcmin pcmax)
457		(loop (cdr rem) pcmin pcmax pc-stack vars))))
458	    (else
459	     (error "phase-1: Unknown directive" this))))))
460  (loop directives starting-pc starting-pc '() '()))
461
462(define (phase-2 widening? vars)
463  (let loop ((vars vars) (modified? #f) (count 0))
464    (if (null? vars)
465	(values modified? count)
466	(call-with-values
467	    (lambda ()
468	      (let ((var (car vars)))
469		(call-with-values
470		    (lambda ()
471		      (interval-values (evaluate (vector-ref var 1)
472						 (vector-ref var 2))))
473		  (lambda (low high)
474		    (process-variable var widening? low high)))))
475	  (lambda (determined? filtered?)
476	    (loop (cdr vars)
477		  (or modified? filtered?)
478		  (if determined? count (+ count 1))))))))
479
480(define (process-variable var widening? minval maxval)
481  (let loop ((dropped-some? #f))
482    (let ((sels (vector-ref var 3)))
483      (if (null? sels)
484	  (error "Variable-width field cannot be resolved:" var))
485      (let ((low (selector/low (car sels)))
486	    (high (selector/high (car sels))))
487	(cond ((and (or (null? low) (<= low minval))
488		    (or (null? high) (<= maxval high)))
489	       (if (not widening?)
490		   (variable-width->fixed! var (car sels)))
491	       (values #t dropped-some?))
492	      ((and (or (null? low) (<= low maxval))
493		    (or (null? high) (<= minval high)))
494	       (values #f dropped-some?))
495	      (else
496	       (vector-set! var 3 (cdr sels))
497	       (loop #t)))))))
498
499(define (variable-width->fixed! var sel)
500  (let* ((l (selector/length sel))
501	 (v (vector 'EVALUATION
502		    (vector-ref var 1)	; Expression
503		    (selector/length sel)
504		    (variable-handler-wrapper (selector/handler sel)))))
505    (vector-set! var 0 'FIXED-WIDTH-GROUP)
506    (vector-set! var 1 l)
507    (vector-set! var 2 (list v))
508    (vector-set! var 3 '())))
509
510(define (variable-handler-wrapper handler)
511  (lambda (value)
512    (let ((l (handler value)))
513      (if (null? l)
514	  (bit-string-allocate 0)
515	  (list->bit-string l)))))
516
517(define (list->bit-string l)
518  (if (null? (cdr l))
519      (car l)
520      (instruction-append (car l)
521			  (list->bit-string (cdr l)))))
522
523(define (replicate bstring n-times)
524  (let* ((blength (bit-string-length bstring))
525	 (result (make-bit-string (* n-times blength) false)))
526    (do ((offset 0 (+ offset blength))
527	 (ctr 0 (1+ ctr)))
528	((>= ctr n-times))
529      (bit-substring-move-right! bstring 0 blength result offset))
530    result))
531
532(define (final-pad! block pc position)
533  (instruction-insert!
534   (replicate padding-string
535	      (quotient (- (final-pad pc) pc)
536			(bit-string-length padding-string)))
537   block
538   position
539   (lambda (new-position)
540     new-position			; ignored
541     unspecific)))
542
543(define (->padding-directive this)
544  (let ((remdr (cadr this))
545	(divsr (caddr this))
546	(bstring (if (null? (cdddr this))
547		     padding-string
548		     (cadddr this))))
549    (vector 'PADDING (modulo remdr divsr) divsr bstring)))
550
551(define-integrable (after-padding directive pcmin pcmax recvr)
552  (let ((remdr (vector-ref directive 1))
553	(divsr (vector-ref directive 2)))
554    (recvr (->bitstring-pc (paddify (->machine-pc pcmin) remdr divsr))
555	   (->bitstring-pc (paddify (->machine-pc pcmax) remdr divsr)))))