DataMuseum.dk

top - download

    Length: 12155 (0x2f7b)
    Types: TextFile
    Names: »spmd.scm.20«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/spmd.scm.20« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Stack Parser Quanta for CScheme Implementation

(in-package (procedure-environment catch)

(declare (usual-integrations)
	 (compilable-primitive-functions primitive-type))
\f


; Known to be omitted return codes:
; PURIFY-GC-1, PURIFY-GC-2, NORMAL-GC-DONE, RESTORE-CONTINUATION,
; RESTART-EXECUTION, REDO-COMPILER-REFERENCE, COMPLETE-GC-DONE,
; AFTER-MEMORY-UPDATE, RESTARTABLE-EXIT

;;; In CScheme a control point contains a copy of the stack in
;;; ascending address order (i.e. from top of stack to base of
;;; stack). Above this are the saved display registers.  On the
;;; very top is interrupt enables.

;;; This is a terrible kludge! The 7 is a hardwired
;;; special constant, which means the interrupts are on.
;;; The displays are all cleared.

(define control-point-number-of-displays 25)
(define manifest-nm-vector-type
  (microcode-type 'MANIFEST-NM-VECTOR))

(define is-a-future?
  (let ((prim (make-primitive-procedure 'FUTURE? #!true)))
    (lambda (object)
      (conjunction
       (implemented-primitive-procedure? prim)
       (prim object)))))

(define (control-point->stack control-point)
  (define (nils n rest)
    (if (= n 0)
	(rest)
	(cons '() (delay (nils (-1+ n) rest)))))
  (if (primitive-type? type-code-control-point control-point)
      (let ((size (system-vector-size control-point)))
        (let loop ((index (+ 2 control-point-number-of-displays)))
          (cond ((= index size) '())
		((conjunction
		  (not (is-a-future? (system-vector-ref control-point index)))
		  (primitive-type?
		   manifest-nm-vector-type
		   (system-vector-ref control-point index)))
		 (let ((N-Skips
			(primitive-datum
			 (system-vector-ref control-point index))))
		   (cons N-Skips
			 (delay (nils n-skips
				      (lambda ()
					(loop (+ index N-Skips 1))))))))
		(else (cons (system-vector-ref control-point index)
			    (delay (loop (1+ index))))))))
      (error "Not a control-point" control-point->stack control-point)))
\f


(define (stack->control-point stack history offset-to-restore)
  (system-list-to-vector 
   type-code-control-point
   `(,15	                   ; 15 is GC + Stack overflow + 
				   ;; Character ints + Timer ints
     ,3				   ; Previous restore history
     ,@(make-list control-point-number-of-displays '())
				   ; Cleared displays
     ,return-address-restore-history
     ,history
     ,offset-to-restore		   ; Previous restore history
     ,@(let loop ((stack stack)
		  (count offset-to-restore))
	  (cond ((null? stack) '())
		((conjunction (zero? count)
			      (not (zero? offset-to-restore)))
		 (if (disjunction
		      (eq? (car stack)
			   return-address-restore-dont-copy-history)
		      (eq? (car stack)
			   return-address-restore-history))
		     (cons return-address-restore-history
			   (loop (force (cdr stack)) -1))
		     (error "Stack->Control-Point: Offset messed up")))
		(else (cons (car stack)
			    (loop (force (cdr stack)) (-1+ count)))))))))
\f


(define (control-point-interrupt-enables control-point)
  (system-vector-ref control-point 0))

(define (set-control-point-interrupt-enables! control-point new-enables)
  (system-vector-set! control-point 0 new-enables))

(define (control-point-offset control-point)
  (system-vector-ref control-point 1))

(define (set-control-point-offset! control-point new-offset)
  (system-vector-set! control-point 1 new-offset))

(define-stack-parser 'NON-EXISTENT-CONTINUATION
  (lambda (stack history dynamic-state offset)
    '()))

(define-stack-parser 'RESTORE-CONTROL-POINT
  (lambda (stack history dynamic-state offset)
    (if (zero? offset)
	(parse-stack (control-point->stack (stack-ref stack 1))
		     history
		     dynamic-state
		     (control-point-offset (stack-ref stack 1)))
	(error "RESTORE-CONTROL-POINT parser: offset should be 0"))))

(define-stack-parser 'INVOKE-STACK-THREAD
  (lambda (stack history dynamic-state offset)
    (make-parser-output (stack-ref stack 0)
			(stack-ref stack 1)
			undefined-environment
			undefined-reductions
			(stack-tail stack 2)
			history
			dynamic-state
			(monus offset 2))))
\f


(define-standard-parser 'ASSIGNMENT-CONTINUE
  parse-standard-frame)

(define-standard-parser 'DEFINITION-CONTINUE
  parse-standard-frame)

(define-standard-parser 'SEQUENCE-2-SECOND
  parse-standard-frame)

(define-standard-parser 'SEQUENCE-3-SECOND
  parse-standard-frame)

(define-standard-parser 'SEQUENCE-3-THIRD
  parse-standard-frame)

(define-standard-parser 'CONDITIONAL-DECIDE
  parse-standard-frame)

(define-standard-parser 'DISJUNCTION-DECIDE
  parse-standard-frame)

(define-standard-parser 'COMBINATION-1-PROCEDURE
  parse-standard-frame)

(define-standard-parser 'COMBINATION-2-FIRST-OPERAND
  parse-standard-frame)

(define-standard-parser 'COMBINATION-2-PROCEDURE
  (lambda (stack history cont)
    (cont (stack-ref stack 0)
	  (stack-ref stack 1)
	  3
	  (stack-ref stack 2))))			;Second operand.
\f


(define-standard-parser 'PRIMITIVE-COMBINATION-1-APPLY
  parse-expression-only-frame)

#|
(define-standard-parser 'REPEAT-DISPATCH      ;Newly added for Morry
  (lambda (stack history cont)
    (cont undefined-expression
	  (stack-ref stack 2)		; The environment
	  3
	  (stack-ref stack 1)		; Dispatch value
	  (stack-ref stack 3))))	; Val
|#

(define-standard-parser 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND
  parse-standard-frame)

(define-standard-parser 'PRIMITIVE-COMBINATION-2-APPLY
  (lambda (stack history cont)
    (cont (stack-ref stack 0)
	  undefined-environment
	  2
	  (stack-ref stack 1))))			;Second operand.

(define-standard-parser 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND
  (lambda (stack history cont)
    (cont (stack-ref stack 0)
	  (stack-ref stack 2)
	  3
	  (stack-ref stack 1))))			;Third operand.

(define-standard-parser 'FORCE-SNAP-THUNK
  (lambda (stack history cont)
    (cont (stack-ref stack 0)
	  undefined-environment
	  1)))

(define (restore-history-parser stack history dynamic-state offset)
  (if (= offset 3)
      (parse-stack (stack-tail stack 3)
		   ((access history-transform history-package)
		    (stack-ref stack 1))
		   dynamic-state
		   (stack-ref stack 2))
      (error "RESTORE-HISTORY parser: Count should be 3")))

(define-stack-parser 'RESTORE-HISTORY restore-history-parser)
(define-stack-parser 'RESTORE-DONT-COPY-HISTORY restore-history-parser)

(define-stack-parser 'RESTORE-TO-STATE-POINT
  (lambda (stack history dynamic-state offset)
    (parse-stack (stack-tail stack 2)
		 history
		 (stack-ref stack 1)
		 (monus offset 2))))
\f


(define-standard-parser 'MOVE-TO-ADJACENT-POINT
  (lambda (stack history cont)
    (cont undefined-expression
	  undefined-environment
	  1
	  (stack-ref stack 1))))                       ;State point.

(define-stack-parser 'RESTORE-INTERRUPT-MASK ;Ignore this frame
  (lambda (stack history dynamic-state offset)
    (parse-stack (stack-tail stack 2)
		 history
		 dynamic-state
		 (monus offset 2))))

(define-standard-parser 'RESTORE-VALUE
  (lambda (stack history cont)
    (cont undefined-expression
	  undefined-environment
	  1
	  (stack-ref stack 1))))	;The value.

(define-stack-parser 'POP-RETURN-ERROR	;Basically ignore this frame
  (lambda (stack history dynamic-state offset)
    (parse-stack (stack-tail stack 2)
		 history
		 dynamic-state
		 (monus offset 2))))
\f



(define-stack-parser 'EVAL-ERROR ; Gobble up RESTORE-HISTORY above here
  (lambda (stack history dynamic-state offset)
    (let ((hist ((access history-transform history-package)
		 (stack-ref stack 4))))
      (make-parser-output
       (stack-ref stack 0)		; Return Address
       (stack-ref stack 1)		; Expression
       (stack-ref stack 2)		; Environment
       ((access history-reductions history-package)
	hist)				; Reductions
       (stack-tail stack 6)		; Rest of stack
       ((access history-superproblem history-package)
	hist)				; History
       dynamic-state
       (stack-ref stack 5)))))		; Offset

(define-standard-parser 'IN-PACKAGE-CONTINUE
  parse-expression-only-frame)

(define-standard-parser 'ACCESS-CONTINUE
  parse-expression-only-frame)

(define ((CScheme-Combination-Parser Count-At parser)
	 stack history cont)
  (let ((Count  (primitive-datum (stack-ref stack Count-At))))
    (stack-split (stack-tail stack (1+ Count-At)) Count
      (lambda (Frame Rest-Of-Stack)
	(parser cont Frame Count (+ Count Count-At 1) Stack)))))

(define-standard-parser 'COMBINATION-SAVE-VALUE
  (lambda (stack history cont)
    (let ((combination (stack-ref stack 0)))
      (let ((size (system-vector-size combination)))
	(stack-split (stack-tail stack 2) size
	  (lambda (Frame Rest-Of-Stack)
	    (cont combination
		  (stack-ref stack 1)
		  (+ size 2)
		  (list-tail 
		   Frame
		   (1+ (primitive-datum (car Frame)))))))))))
\f


(define-standard-parser 'COMBINATION-APPLY
  (CScheme-Combination-Parser 1
    (lambda (cont frame frame-length skip stack)
      (cont undefined-expression
	    undefined-environment
	    skip
	    (list->vector (cdr frame))))))  ; Eval'ed args

(define-standard-parser 'INTERNAL-APPLY
  (CScheme-Combination-Parser 1
    (lambda (cont frame frame-length skip stack)
      (cont (make-combination
	     (make-evaluated-object (car frame))
	     (mapcar make-evaluated-object (cdr frame)))
	    undefined-environment
	    skip))))

(define-standard-parser 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND
  parse-standard-frame)

(define-standard-parser 'PRIMITIVE-COMBINATION-3-APPLY
  (lambda (stack history cont)
    (cont (stack-ref stack 0)
	  undefined-environment
	  3
	  (stack-ref stack 2)				;Third operand.
	  (stack-ref stack 1))))			;Second operand.
\f


(define-standard-parser 'REPEAT-PRIMITIVE
; Reconstruct a fully evaluated combination which would have called
; this primitive with these arguments.  The primitive itself is
; where the expression would normally appear in a stack frame,
; followed by its arguments.
  (lambda (stack history cont)
    (let ((primitive (stack-ref stack 0)))
      (let ((NArgs (primitive-procedure-arity primitive)))
	(stack-split
	 (stack-tail stack 1)
	 NArgs
	 (lambda (Args Rest-Of-Stack)
	   (cont (make-combination
                  (make-evaluated-object primitive)
                  (mapcar make-evaluated-object Args))
		 undefined-environment
		 (1+ NArgs))))))))

(define (compiled-code-parser stack history cont)
  (cont '(COMPILED CODE HERE)
	undefined-environment
	1))

(define-standard-parser 'COMPILER-ENTRY-GC compiled-code-parser)
(define-standard-parser 'COMPILER-RECURSION-GC compiled-code-parser)

;;; end IN-PACKAGE PRIMITIVE-CONTINUATION.
)

;;; Local Modes:
;;; Scheme CSCHEME-COMBINATION-PARSER Indent: 1
;;; Scheme STACK-SPLIT Indent: 2
;;; End: