conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pcs/newpcs/pboot.s

409 lines
12 KiB
ArmAsm
Raw Permalink Normal View History

Unpack disk2.tgz
2023-05-20 05:57:05 -04:00
; -*- 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))))))))