#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.3 1992/02/05 14:57:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.4 1992/02/05 17:21:48 jinx Exp $
$MC68020-Header: /scheme/compiler/bobcat/RCS/lapgen.scm,v 4.42 1991/05/28 19:14:26 jinx Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(else
(error "Unknown expression type" (car expression))))))
\f
+;;;; Named registers, codes, and entries
+
+(define reg:compiled-memtop
+ #|
+ (INST-EA (@RO ,regnum:regs-pointer ,(* 4 register-block/memtop-offset)))
+ |#
+ (INST-EA (@R ,regnum:regs-pointer)))
+
+(define reg:environment
+ (INST-EA (@RO ,regnum:regs-pointer
+ ,(* 4 register-block/environment-offset))))
+
+(define reg:dynamic-link
+ (INST-EA (@RO ,regnum:regs-pointer
+ ,(* 4 register-block/dynamic-link-offset))))
+
+(define reg:lexpr-primitive-arity
+ (INST-EA (@RO ,regnum:regs-pointer
+ ,(* 4 register-block/lexpr-primitive-arity-offset))))
+
+(define reg:utility-arg-4
+ (INST-EA (@RO ,regnum:regs-pointer
+ ,(* 4 register-block/utility-arg4-offset))))
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (1+ index)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo))
+
+(define-integrable (invoke-interface code)
+ (LAP (MOV W (R ,eax) (& ,code))
+ (JMP ,entry:compiler-scheme-to-interface)))
+
+(define-integrable (invoke-interface/call code)
+ (LAP (MOV W (R ,eax) (& ,code))
+ (JSR ,entry:compiler-scheme-to-interface/call)))
+\f
+(let-syntax ((define-entries
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ (INST-EA (@RO ,regnum:regs-pointer ,index)))
+ (loop (cdr names) (+ index 4)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-entries (* 16 4)
+ scheme-to-interface ; Main entry point (only one necessary)
+ scheme-to-interface/call ; Used by rules3&4, for convenience.
+ trampoline-to-interface ; Used by trampolines, for convenience.
+ interrupt-procedure
+ interrupt-continuation
+ interrupt-closure
+ interrupt-dlink
+ #|
+ ;; Not yet available
+ primitive-apply
+ primitive-lexpr-apply
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ quotient
+ remainder
+ modulo
+ shortcircuit-apply ; Used by rules3, for speed.
+ shortcircuit-apply-size-1 ; Small frames, save time and space.
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ link
+ error
+ primitive-error
+ |#
+ ))
+\f
;;; *** Here ***
;;;; Register-Allocator Interface
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/machin.scm,v 1.5 1992/02/05 14:57:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/machin.scm,v 1.6 1992/02/05 17:22:24 jinx Exp $
$MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/machin.scm,v 4.26 1991/10/25 06:49:34 cph Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(define-integrable register-block/environment-offset 3)
(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
(define-integrable register-block/utility-arg4-offset 9) ; closure free
+(define-integrable register-block/lexpr-primitive-arity-offset 7)
\f
;;;; RTL Generator Interface
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules3.scm,v 1.6 1992/02/05 14:56:45 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules3.scm,v 1.7 1992/02/05 17:18:36 jinx Exp $
$MC68020-Header: /scheme/compiler/bobcat/RCS/rules3.scm,v 4.31 1991/05/28 19:14:55 jinx Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(INVOCATION:APPLY (? frame-size) (? continuation))
continuation
(LAP ,@(clear-map!)
+ #|
,@(case frame-size
((1) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-1)))
((2) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-2)))
((8) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-8)))
(else
(LAP (MOV W (R ,ecx) (& ,frame-size))
- (JMP ,entry:compiler-shortcircuit-apply))))))
+ (JMP ,entry:compiler-shortcircuit-apply))))
+ |#
+ (MOV W (R ,ecx) (& ,frame-size))
+ ,@(invoke-interface code:compiler-apply)))
(define-rule statement
(INVOCATION:JUMP (? frame-size) (? continuation) (? label))
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
- continuation
+ #|
+ (define-integrable (invoke code entry)
+ code ; ignored
+ (LAP (JMP ,entry)))
+ |#
+ (define-integrable (invoke code entry)
+ entry ; ignored
+ (invoke-interface code))
+
+ continuation ; ignored
(if (eq? primitive compiled-error-procedure)
(LAP ,@(clear-map!)
(MOV W (R ,ecx) (& ,frame-size))
- (JMP ,entry:compiler-error))
+ ,@(invoke code:compiler-error entry:compiler-error))
(let ((arity (primitive-procedure-arity primitive))
(get-code (object->machine-register! primitive ecx)))
(cond ((not (negative? arity))
(LAP ,@get-code
,@(clear-map!)
- (JMP ,entry:compiler-primitive-apply)))
+ ,@(invoke code:compiler-apply
+ entry:compiler-primitive-apply)))
((= arity -1)
(LAP ,@get-code
,@(clear-map!)
(MOV W ,reg:lexpr-primitive-arity (& ,(-1+ frame-size)))
- (JMP ,entry:compiler-primitive-lexpr-apply)))
+ ,@(invoke code:compiler-primitive-lexpr-apply
+ entry:compiler-primitive-lexpr-apply)))
(else
;; Unknown primitive arity. Go through apply.
(LAP ,@get-code
(optimized-primitive-invocation
,(symbol-append 'ENTRY:COMPILER- name))))))
- (define-optimized-primitive-invocation &+)
- (define-optimized-primitive-invocation &-)
- (define-optimized-primitive-invocation &*)
- (define-optimized-primitive-invocation &/)
- (define-optimized-primitive-invocation &=)
- (define-optimized-primitive-invocation &<)
- (define-optimized-primitive-invocation &>)
- (define-optimized-primitive-invocation 1+)
- (define-optimized-primitive-invocation -1+)
- (define-optimized-primitive-invocation zero?)
- (define-optimized-primitive-invocation positive?)
- (define-optimized-primitive-invocation negative?)
- (define-optimized-primitive-invocation quotient)
- (define-optimized-primitive-invocation remainder))
+ (let-syntax ((define-primitive-invocation
+ (macro (name)
+ ;; For now.
+ `(define-special-primitive-invocation ,name))))
+
+ (define-primitive-invocation &+)
+ (define-primitive-invocation &-)
+ (define-primitive-invocation &*)
+ (define-primitive-invocation &/)
+ (define-primitive-invocation &=)
+ (define-primitive-invocation &<)
+ (define-primitive-invocation &>)
+ (define-primitive-invocation 1+)
+ (define-primitive-invocation -1+)
+ (define-primitive-invocation zero?)
+ (define-primitive-invocation positive?)
+ (define-primitive-invocation negative?)
+ (define-primitive-invocation quotient)
+ (define-primitive-invocation remainder)))
(define (special-primitive-invocation code)
(LAP ,@(clear-map!)
,@(invoke-interface code)))
-(define (optimized-primitive-invocation hook)
+(define (optimized-primitive-invocation entry)
(LAP ,@(clear-map!)
- (JMP ,hook)))
+ (JMP ,entry)))
;;; Invocation Prefixes
(LEA (R ,edx) (@RO ,eax (- ,*block-label* ,pc-label)))
(LEA (R ,ebx) (@RO ,eax (- ,free-ref-label ,pc-label)))
(MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
(CALL ,entry:compiler-link)
+ |#
+ ,@(invoke-interface/call code:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label))))))
(MOV W (R ,ecx) ,reg:environment)
(MOV W (@RO ,edx ,environment-offset) (R ,ecx))
(MOV W ,reg:utility-arg-4 (& ,n-sections))
+ #|
(CALL ,entry:compiler-link)
+ |#
+ ,@(invoke-interface/call code:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label))))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules4.scm,v 1.1 1992/02/01 14:44:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules4.scm,v 1.2 1992/02/05 17:20:37 jinx Exp $
$mc68020-Header: rules4.scm,v 4.12 90/05/03 15:17:38 GMT jinx Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(interpreter-call-argument->machine-register! extension edx)))
(LAP ,@set-extension
,@(clear-map!)
+ #|
(CALL ,(if safe?
entry:compiler-safe-reference-trap
- entry:compiler-reference-trap)))))
+ entry:compiler-reference-trap))
+ |#
+ ,@(invoke-interface/call
+ (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
(LAP ,@set-extension
,@set-value
,@(clear-map!)
- (CALL ,entry:compiler-assignment-trap))))
+ #|
+ (CALL ,entry:compiler-assignment-trap)
+ |#
+ ,@(invoke-interface/call code:compiler-assignment-trap))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension))
projects / mit-scheme.git / commitdiff