409 lines
12 KiB
Common Lisp
409 lines
12 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pboot.s
|
||
|
||
; Last Revision: 3-Sep-85 1500ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; Bootstrap Driver ;
|
||
; ;
|
||
; ;
|
||
; This routine contains compiler-specific code which should be used ;
|
||
; when compiling the compiler itself. It is generally loaded by the ;
|
||
; file "COMPILE.ALL" which handles compilation of the compiler and ;
|
||
; runtime routines. ;
|
||
; ;
|
||
; The file contains compiler-type definitions and macro definitions ;
|
||
; which must be included when compiling the compiler files. ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
(begin
|
||
;
|
||
; Define aliases for the major parts of the compiler
|
||
;
|
||
(alias pme pcs-macro-expand)
|
||
(alias psimp pcs-simplify)
|
||
(alias pca pcs-closure-analysis)
|
||
(alias pmr pcs-make-readable)
|
||
(alias pcg pcs-gencode)
|
||
(alias ppeep pcs-postgen)
|
||
(alias pal pcs-princode)
|
||
(alias pasm pcs-assembler)
|
||
|
||
;
|
||
; Initialize compile-time variable definitions
|
||
;
|
||
(set! pcs-local-var-count 0)
|
||
(set! pcs-verbose-flag #!true)
|
||
(set! pcs-permit-peep-1 #!true)
|
||
(set! pcs-permit-peep-2 #!true)
|
||
(set! pcs-error-flag #!false)
|
||
(set! pcs-binary-output #!false)
|
||
|
||
;
|
||
; Set up variables to hold compiler-intermediate data and timing info
|
||
;
|
||
(define pme= '())
|
||
(define psimp= '())
|
||
(define pca= '())
|
||
(define pcg= '())
|
||
(define ppeep= '())
|
||
(define pasm= '())
|
||
(define problem)
|
||
(define t-0)
|
||
(define t-pme)
|
||
(define t-psimp)
|
||
(define t-pca)
|
||
(define t-pcg)
|
||
(define t-ppeep)
|
||
(define t-pasm)
|
||
)
|
||
|
||
;;; --------------------------------------------------------------------
|
||
;;;
|
||
;;; "Type definitions"
|
||
;;;
|
||
;;; The following macros are used by the compiler itself and must
|
||
;;; be defined when compiling the compiler. By keeping them here,
|
||
;;; the macro definitions will not be around in the object files
|
||
;;; of the compiler
|
||
;;;
|
||
;;; --------------------------------------------------------------------
|
||
|
||
(macro pcs-make-id ; PCS-MAKE-ID
|
||
(lambda (form)
|
||
(let ((name (cadr form)))
|
||
`(begin
|
||
(set! pcs-local-var-count (+ pcs-local-var-count 1))
|
||
(list 'T ; the symbol T, not #!TRUE !!
|
||
(cons ,name
|
||
pcs-local-var-count)
|
||
'() '() '())))))
|
||
|
||
|
||
;;; ---- (t (original-name . unique-number)
|
||
;;; funargsees? freeref? set!? . init) ----
|
||
|
||
(begin
|
||
(syntax (id-name id) (caadr id))
|
||
(syntax (id-number id) (cdadr id))
|
||
(syntax (id-funargsees? id) (car (cddr id)))
|
||
(syntax (id-freeref? id) (car (cdddr id)))
|
||
(syntax (id-set!? id) (cadr (cdddr id)))
|
||
(syntax (id-init id) (cddr (cdddr id)))
|
||
|
||
(syntax (id-rtv? id)
|
||
(or (id-set!? id)
|
||
(null? (id-init id))
|
||
(lambda-closed? (id-init id))))
|
||
|
||
(syntax (id-heap? id)
|
||
(and (id-funargsees? id)
|
||
(id-freeref? id)
|
||
(id-rtv? id)))
|
||
|
||
(syntax (set-id-funargsees? id val) (set-car! (cddr id) val))
|
||
(syntax (set-id-freeref? id val) (set-car! (cdddr id) val))
|
||
(syntax (set-id-set!? id val) (set-car! (cdr (cdddr id)) val))
|
||
(syntax (set-id-init id val) (set-cdr! (cdr (cdddr id)) val))
|
||
)
|
||
|
||
;;; ------ (lambda bvl body . (nargs label . closed)) ------
|
||
|
||
(begin
|
||
(syntax (lambda-bvl x) (car (cdr x)))
|
||
(syntax (lambda-body x) (car (cddr x)))
|
||
(syntax (lambda-body-list x) (cddr x))
|
||
(syntax (lambda-nargs x) (car (cdddr x)))
|
||
(syntax (lambda-label x) (car (cdr (cdddr x))))
|
||
(syntax (lambda-debug x) (car (cddr (cdddr x))))
|
||
(syntax (lambda-closed? x) (car (cdddr (cdddr x))))
|
||
|
||
(syntax (set-lambda-body x val) (set-car! (cddr x) val))
|
||
(syntax (set-lambda-nargs x val) (set-car! (cdddr x) val))
|
||
(syntax (set-lambda-label x val) (set-car! (cdr (cdddr x)) val))
|
||
(syntax (set-lambda-debug x val) (set-car! (cddr (cdddr x)) val))
|
||
(syntax (set-lambda-closed? x val) (set-car! (cdddr (cdddr x)) val))
|
||
|
||
(macro pcs-extend-lambda
|
||
(lambda (form)
|
||
`(let ((x ,(cadr form)))
|
||
(set-cdr! (cdddr x) ; X = ('lambda bvl body nargs)
|
||
(list '() ; label
|
||
'() ; debug info
|
||
'())) ; closed?
|
||
x)))
|
||
)
|
||
|
||
;;; ------ (letrec pairs body) ------
|
||
|
||
(begin
|
||
(syntax (letrec-pairs x) (car (cdr x)))
|
||
(syntax (letrec-body x) (car (cddr x)))
|
||
(syntax (letrec-body-list x) (cddr x))
|
||
|
||
(syntax (set-letrec-body x val) (set-car! (cddr x) val))
|
||
)
|
||
|
||
;;; ------ (if pred then else) ------
|
||
|
||
(begin
|
||
(syntax (if-pred x) (car (cdr x)))
|
||
(syntax (if-then x) (car (cddr x)))
|
||
(syntax (if-else x) (car (cdddr x)))
|
||
|
||
(syntax (set-if-pred x val) (set-car! (cdr x) val))
|
||
(syntax (set-if-then x val) (set-car! (cddr x) val))
|
||
(syntax (set-if-else x val) (set-car! (cdddr x) val))
|
||
)
|
||
|
||
;;; ------ (set! id exp) ------
|
||
|
||
(begin
|
||
(syntax (set!-id x) (car (cdr x)))
|
||
(syntax (set!-exp x) (car (cddr x)))
|
||
|
||
(syntax (set-set!-id x val) (set-car! (cdr x) val))
|
||
(syntax (set-set!-exp x val) (set-car! (cddr x) val))
|
||
)
|
||
|
||
;;; --------------------------------------------------------------------
|
||
|
||
(define pcs-make-readable ; PCS-MAKE-READABLE
|
||
(lambda (x)
|
||
(letrec
|
||
;-------!
|
||
((pmr-exp
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
x
|
||
(case (car x)
|
||
(quote x)
|
||
(t (pmr-id x))
|
||
(lambda (pmr-lambda x))
|
||
(letrec (pmr-letrec x))
|
||
(else (mapcar pmr-exp x))))))
|
||
|
||
(pmr-id
|
||
(lambda (x)(cadr x)))
|
||
|
||
(pmr-full-id
|
||
(lambda (x)
|
||
`(t (,(id-name x) . ,(id-number x))
|
||
(funargsees?= ,(id-funargsees? x))
|
||
(freeref?= ,(id-freeref? x))
|
||
(set!?= ,(id-set!? x))
|
||
(init= ,(if (id-init x) 'lambda '())))))
|
||
|
||
(pmr-lambda
|
||
(lambda (x)
|
||
`(lambda
|
||
,(mapcar pmr-full-id (lambda-bvl x))
|
||
,(pmr-exp (lambda-body x))
|
||
(label= ,(lambda-label x))
|
||
(closed?= ,(lambda-closed? x)))))
|
||
|
||
(pmr-letrec
|
||
(lambda (x)
|
||
`(letrec
|
||
,(pmr-pairs (letrec-pairs x) '())
|
||
,(pmr-exp (letrec-body x)))))
|
||
|
||
(pmr-pairs
|
||
(lambda (old new)
|
||
(if (null? old)
|
||
(reverse! new)
|
||
(pmr-pairs (cdr old)
|
||
(cons (list (pmr-full-id (caar old))
|
||
(pmr-exp (cadar old)))
|
||
new)))))
|
||
|
||
)
|
||
(pmr-exp x))))
|
||
|
||
;;; --------------------------------------------------------------------
|
||
|
||
;
|
||
; filename-manipulating functions
|
||
;
|
||
(define filename-sans-extension
|
||
(lambda (file)
|
||
(let ((period (substring-find-next-char-in-set
|
||
file 0 (string-length file) ".")))
|
||
(if period
|
||
(substring file 0 period)
|
||
file))))
|
||
|
||
(define extension-sans-filename
|
||
(lambda (file)
|
||
(let ((period (substring-find-next-char-in-set
|
||
file 0 (string-length file) ".")))
|
||
(if period
|
||
(substring file period (string-length file))
|
||
""))))
|
||
|
||
;;; --------------------------------------------------------------------
|
||
|
||
;
|
||
; Routine to compile a form, setting timing info and intermediate (between
|
||
; compiler phases) data.
|
||
;
|
||
(define pcs
|
||
(lambda (exp)
|
||
(begin
|
||
(set! pme= '())
|
||
(set! psimp= '())
|
||
(set! pca= '())
|
||
(set! pcg= '())
|
||
(set! pasm= '())
|
||
(set! pcs-local-var-count 0)
|
||
(set! problem exp)
|
||
(set! pcs-error-flag #!false)
|
||
(set! t-0 (car (ptime)))
|
||
(set! pme= (pme exp ))
|
||
(set! t-pme (car (ptime)))
|
||
(if pcs-error-flag
|
||
(error "[Compilation terminated because of errors]")
|
||
(begin
|
||
(set! psimp= (psimp pme=))
|
||
(set! t-psimp (car (ptime)))
|
||
(pca psimp=)
|
||
(set! t-pca (car (ptime)))
|
||
(set! pcg= (pcg psimp=))
|
||
(set! t-pcg (car (ptime)))
|
||
(set! ppeep= (ppeep pcg=))
|
||
(set! t-ppeep (car (ptime)))
|
||
(set! pasm= (pasm ppeep=))
|
||
(set! t-pasm (car (ptime)))
|
||
))
|
||
`(Times- Total= ,(- t-pasm t-0)
|
||
pme= ,(- t-pme t-0)
|
||
psimp= ,(- t-psimp t-pme)
|
||
pca= ,(- t-pca t-psimp)
|
||
pcg= ,(- t-pcg t-pca)
|
||
ppeep= ,(- t-ppeep t-pcg)
|
||
pasm= ,(- t-pasm t-ppeep))
|
||
)))
|
||
|
||
;
|
||
; Compiles a given expression without executing the result
|
||
;
|
||
(define pcs-compile
|
||
(lambda (exp)
|
||
(set! pcs-verbose-flag #!false)
|
||
(set! pcs-binary-output #!true)
|
||
(set! pcs-local-var-count 0)
|
||
(set! pcs-error-flag #!false)
|
||
(let ((t1 (pme exp)))
|
||
(if pcs-error-flag
|
||
(error "[Compilation terminated because of errors.]")
|
||
(let ((t2 (psimp t1)))
|
||
(pca t2)
|
||
(pasm (ppeep (pcg t2))))))))
|
||
|
||
|
||
;
|
||
; Set up compile-time aliases. When encountered in a source file,
|
||
; anything assigned via compile-time-alias will be defined as
|
||
; an alias, but will not be written to the object file.
|
||
; See pcs-compile-file in this file !!!
|
||
;
|
||
(alias compile-time-alias alias)
|
||
|
||
|
||
;
|
||
; Compiles a given file without executing (unless form is a macro, alias,
|
||
; syntax, or define-integrable) the result. Also report compilation info.
|
||
;
|
||
(define pcs-compile-file
|
||
(lambda (filename1 filename2)
|
||
(if (or (not (string? filename1))
|
||
(not (string? filename2))
|
||
(equal? filename1 filename2))
|
||
(error "PCS-COMPILE-FILE arguments must be distinct file names"
|
||
filename1
|
||
filename2)
|
||
(fluid-let ((input-port (open-input-file filename1)))
|
||
(let ((o-port (open-output-file filename2)))
|
||
(letrec
|
||
((loop
|
||
(lambda (form)
|
||
(if (eof-object? form)
|
||
(begin (close-input-port (fluid input-port))
|
||
(close-output-port o-port)
|
||
'ok)
|
||
(begin (compile-to-file form)
|
||
(set! form '()) ; for GC
|
||
(loop (read))))))
|
||
(compile-to-file
|
||
(lambda (form)
|
||
(let* ((cform (pcs-compile form))
|
||
(nconstants (cadr cform))
|
||
(nbytes (caddr cform))
|
||
(name?? (car (cadddr cform))))
|
||
(if (pair? form)
|
||
(if (eq? (car form) 'COMPILE-TIME-ALIAS)
|
||
(%execute cform)
|
||
;else
|
||
(begin
|
||
(when (and (pair? form)
|
||
(memq (car form)
|
||
'(MACRO SYNTAX ALIAS
|
||
DEFINE-INTEGRABLE)))
|
||
(%execute cform))
|
||
(writeln " " name?? ": ("
|
||
nconstants "," nbytes ")")
|
||
(fluid-let ((output-port o-port))
|
||
(set-line-length! 74) ; was 120 !!
|
||
(prin1 `(%execute (quote ,cform)))
|
||
(newline)))))))))
|
||
(loop (read))))))))
|
||
;
|
||
; Compile object code to file. The code generated by ppeep (the peephole
|
||
; optimizer is written to the specified file.
|
||
;
|
||
;
|
||
(define %compile-file
|
||
(lambda (filename1 filename2)
|
||
(if (or (not (string? filename1))
|
||
(not (string? filename2))
|
||
(equal? filename1 filename2))
|
||
(error "%COMPILE-FILE arguments must be distinct file names"
|
||
filename1
|
||
filename2)
|
||
(fluid-let ((input-port (open-input-file filename1)))
|
||
(let ((o-port (open-output-file filename2)))
|
||
(letrec
|
||
((loop
|
||
(lambda (form)
|
||
(if (eof-object? form)
|
||
(begin (close-input-port (fluid input-port))
|
||
(close-output-port o-port)
|
||
'ok)
|
||
(begin (compile-to-file form)
|
||
(set! form '()) ; for GC
|
||
(loop (read))))))
|
||
(compile-to-file
|
||
(lambda (form)
|
||
(let ((t1 (pme form)))
|
||
(if pcs-error-flag
|
||
(writeln "[Compilation terminated because of errors.]")
|
||
(let ((t2 (psimp t1)))
|
||
(pca t2)
|
||
(set! ppeep= (ppeep (pcg t2))))))
|
||
(fluid-let ((output-port o-port))
|
||
(set-line-length! 74) ; was 120 !!
|
||
(newline)
|
||
(pp form)
|
||
(newline)
|
||
(pcs-princode ppeep=)
|
||
(newline)))))
|
||
(loop (read))))))))
|
||
|
||
|