#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Miscellaneous Global Definitions
;;; package: (runtime miscellaneous-global)

(declare (usual-integrations))

(add-boot-deps! '(runtime microcode-tables))

;;;; Primitive Operators

(define-primitives
  error-procedure
  get-interrupt-enables set-interrupt-enables! with-interrupt-mask
  get-fixed-objects-vector with-history-disabled
  (primitive-procedure-arity 1)
  (primitive-procedure-documentation 1)

  ;; Environment
  lexical-reference lexical-assignment local-assignment
  lexical-unassigned? lexical-unbound? lexical-unreferenceable?

  ;; Pointers
  (object-type 1)
  (object-datum 1)
  (object-type? 2)
  (object-new-type object-set-type 2)
  make-non-pointer-object

  ;; System Compound Datatypes
  system-pair-cons system-pair?
  system-pair-car system-pair-set-car!
  system-pair-cdr system-pair-set-cdr!

  hunk3-cons
  system-hunk3-cxr0 system-hunk3-set-cxr0!
  system-hunk3-cxr1 system-hunk3-set-cxr1!
  system-hunk3-cxr2 system-hunk3-set-cxr2!

  (system-list->vector system-list-to-vector)
  (system-subvector->list system-subvector-to-list)
  system-vector?
  (system-vector-length system-vector-size)
  system-vector-ref
  system-vector-set!

  primitive-object-ref primitive-object-set!
  (primitive-object-hash 1)
  (primitive-object-hash-2 2)
  (primitive-memory-hash 3))

(define (host-big-endian?)
  host-big-endian?-saved)

;; Assumptions:
;; * Word length is 32 or 64 bits.
;; * Type codes are at most 8 bits.
;; * Zero is a non-pointer type code.
(define-deferred host-big-endian?-saved
  (case (object-datum
	 (vector-ref
	  (object-new-type (ucode-type vector)
			   (bytevector 0 1 2 0 0 3 4 0))
	  1))
    ((#x00010200 #x0001020000030400) #t)
    ((#x00020100 #x0004030000020100) #f)
    (else (error "Unable to determine endianness of host."))))

;;;; Potpourri

(define (identity-procedure x) x)
(define (constant-procedure k) (lambda args (declare (ignore args)) k))
(define (null-procedure . args) args '())
(define (false-procedure . args) args #f)
(define (true-procedure . args) args #t)

(define (eval expression environment)
  (extended-scode-eval (syntax expression environment) environment))

(define (scode-eval scode environment)
  (hook/scode-eval scode environment))

(define hook/scode-eval
  (ucode-primitive scode-eval))

(define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2)
  (object-new-type type (hunk3-cons cxr0 cxr1 cxr2)))

(define (limit-interrupts! limit-mask)
  (set-interrupt-enables! (fix:and limit-mask (get-interrupt-enables))))

(define-integrable (object-component-binder get-component set-component!)
  (lambda (object value thunk)
    (define (swap!)
      (let ((value* value))
	(set! value (get-component object))
	(set-component! object value*)))
    (shallow-fluid-bind swap! thunk swap!)))

(define bind-cell-contents!
  (object-component-binder cell-contents set-cell-contents!))

(define (edit . args)
  (let ((env (let ((package (name->package '(edwin))))
	       (and package (package/environment package)))))
    (if env
	(apply (environment-lookup env 'edit) args)
	(begin
	  (with-notification
	   (lambda (port) (display "Loading Edwin" port))
	   (lambda ()
	     (parameterize ((param:suppress-loading-message? #t))
	       (load-option 'edwin)
	       (if (let ((display (get-environment-variable "DISPLAY")))
		     (and (string? display)
			  (not (string-null? display))))
		   (ignore-errors (lambda () (load-option 'x11-screen)))))))
	  (apply (environment-lookup (->environment '(edwin)) 'edit) args)))))

(define edwin edit)

(define (spawn-edwin . args)
  (let ((thread (create-thread #f (lambda () (apply edwin args)))))
    (detach-thread thread)
    thread))

(define (pa procedure)
  (guarantee procedure? procedure 'pa)
  (cond ((procedure-lambda procedure)
	 => (lambda (scode)
	      (pp (unsyntax-lambda-list scode))))
	((and (primitive-procedure? procedure)
	      (primitive-procedure-documentation procedure))
	 => (lambda (documentation)
	      (display documentation)
	      (newline)))
	(else
	 (display "No documentation or debugging info for ")
	 (display procedure)
	 (display ".")
	 (newline))))

(define (pwd)
  (working-directory-pathname))

(define (cd #!optional pathname)
  (set-working-directory-pathname!
    (if (default-object? pathname)
        (user-homedir-pathname)
	pathname)))

(define (show-time thunk)
  (let ((process-start (process-time-clock))
	(process-start/nogc (runtime))
	(real-start (real-time-clock)))
    (let ((value (thunk)))
      (let* ((process-end (process-time-clock))
	     (process-end/nogc (runtime))
	     (real-end (real-time-clock))
	     (process-time (- process-end process-start))
	     (process-time/nogc
	      (round->exact (* 1000 (- process-end/nogc process-start/nogc)))))
	(write-notification-line
	 (lambda (port)
	   (write-string "process time: " port)
	   (write process-time port)
	   (write-string " (" port)
	   (write process-time/nogc port)
	   (write-string " RUN + " port)
	   (write (- process-time process-time/nogc) port)
	   (write-string " GC); real time: " port)
	   (write (- real-end real-start) port))))
      value)))

(define (wait-interval ticks)
  (let ((end (+ (real-time-clock) ticks)))
    (let wait-loop ()
      (if (< (real-time-clock) end)
	  (wait-loop)))))

(define (exit #!optional object)
  ((param:exit-hook) (exit-object->code object)))

(define (default-exit code)
  (event-distributor/invoke! event:before-exit)
  (within-continuation root-continuation
    (lambda ()
      ((ucode-primitive exit-with-value 1) code))))

(define-deferred param:exit-hook
  (make-settable-parameter default-exit))

(define (emergency-exit #!optional object)
  ((ucode-primitive exit-with-value 1) (exit-object->code object)))

(define (exit-object->code object)
  (cond ((or (eq? #t object) (default-object? object))
	 normal-termination-code)
	((not object)
	 abnormal-termination-code)
	((and (exact-nonnegative-integer? object)
	      (< object (microcode-termination/code-limit)))
	 object)
	((and (interned-symbol? object)
	      (microcode-termination/name->code object)))
	(else
	 abnormal-termination-code)))

(define-deferred normal-termination-code
  (microcode-termination/name->code 'halt))

(define-deferred abnormal-termination-code
  (microcode-termination/name->code 'save-and-exit))

(define (suspend)
  ((param:suspend-hook)))

(define (default-suspend)
  (with-absolutely-no-interrupts (ucode-primitive halt)))

(define-deferred param:suspend-hook
  (make-settable-parameter default-suspend))

(define user-initial-environment
  (*make-environment system-global-environment
		     (vector scode-lambda-name:unnamed)))

(define user-initial-prompt
  "]=>")

(define (link-variables target-environment target-name
			source-environment source-name)
  ((ucode-primitive link-variables 4) (->environment target-environment)
				      target-name
				      (->environment source-environment)
				      source-name))

(define (environment-link-name target-environment source-environment name)
  ;; Obsolete; for backwards compatibility.
  (link-variables target-environment name source-environment name))

(define (unbind-variable environment name)
  ((ucode-primitive unbind-variable 2) (->environment environment) name))

(define (object-gc-type object)
  (%encode-gc-type ((ucode-primitive object-gc-type 1) object)))

(define (type-code->gc-type code)
  (%encode-gc-type ((ucode-primitive type->gc-type 1) code)))

(define (%encode-gc-type t)
  (if (not (and (fix:fixnum? t)
		(fix:>= t -4)
		(fix:<= t 5)))
      (error "Illegal GC-type value:" t))
  ;; Must match enum gc_type_t in microcode/gc.h.
  (vector-ref '#(compiled-entry vector gc-internal undefined non-pointer
				cell pair triple quadruple compiled-return)
	      (fix:+ t 4)))

(define (object-non-pointer? object)
  (case (object-gc-type object)
    ((non-pointer) #t)
    ((gc-internal)
     (or (object-type? (ucode-type manifest-nm-vector) object)
	 (and (object-type? (ucode-type reference-trap) object)
	      (<= (object-datum object) trap-max-immediate))))
    (else #f)))

(define (object-pointer? object)
  (case (object-gc-type object)
    ((cell pair triple quadruple vector compiled-entry) #t)
    ((gc-internal)
     (or (object-type? (ucode-type broken-heart) object)
	 (and (object-type? (ucode-type reference-trap) object)
	      (> (object-datum object) trap-max-immediate))))
    (else #f)))

(define (non-pointer-type-code? code)
  (case (type-code->gc-type code)
    ((non-pointer) #t)
    ((gc-internal) (fix:= (ucode-type manifest-nm-vector) code))
    (else #f)))

(define (pointer-type-code? code)
  (case (type-code->gc-type code)
    ((cell pair triple quadruple vector compiled-entry compiled-return) #t)
    ((gc-internal) (fix:= (ucode-type broken-heart) code))
    (else #f)))

(define (undefined-value? object)
  ;; Note: the printer takes advantage of the fact that objects
  ;; satisfying this predicate also satisfy:
  ;; (object-type? (ucode-type constant) object)
  (or (eq? object unspecific)
      (eq? object (object-new-type (ucode-type constant) 2))))

(define unspecific
  (object-new-type (ucode-type constant) 1))

(define (strip-angle-brackets name)
  (let ((maybe-strip
	 (lambda (s)
	   (and (string-prefix? "<" s)
		(string-suffix? ">" s)
		(substring s 1 (fix:- (string-length s) 1))))))
    (if (string? name)
	(or (maybe-strip name) name)
	(let ((s (maybe-strip (symbol->string name))))
	  (if s
	      (string->symbol s)
	      name)))))

(define (for-each-interned-symbol procedure)
  (with-obarray-lock
    (lambda ()
      (for-each-symbol-in-obarray (fixed-objects-item 'obarray) procedure))))

(define (for-each-symbol-in-obarray obarray procedure)
  (let per-bucket ((index (vector-length obarray)))
    (if (fix:> index 0)
	(let ((index (fix:- index 1)))
	  (let per-symbol
	      ((this (vector-ref obarray index))
	       (set-prev! (lambda (next) (vector-set! obarray index next))))
	    (cond ((weak-pair? this)
		   (let ((symbol (weak-car this))
			 (next (weak-cdr this)))
		     (if (gc-reclaimed-object? symbol)
			 (begin
			   (set-prev! next)
			   (per-symbol next set-prev!))
			 (begin
			   (procedure symbol)
			   (per-symbol next
				       (lambda (next)
					 (weak-set-cdr! this next)))))))
		  ((pair? this)
		   (procedure (car this))
		   (per-symbol (cdr this) (lambda (next) (set-cdr! this next))))
		  (else
		   (per-bucket index))))))))

(define (obarray->list #!optional obarray)
  (let ((list '()))
    (define (accumulate symbol)
      (set! list (cons symbol list))
      unspecific)
    (if (default-object? obarray)
	(for-each-interned-symbol accumulate)
	(for-each-symbol-in-obarray obarray accumulate))
    list))

(define (clean-obarray)
  (with-obarray-lock
   (lambda ()
     (let ((obarray (fixed-objects-item 'obarray)))
       (for-each-symbol-in-obarray obarray
	 (lambda (symbol)
	   (declare (ignore symbol))
	   unspecific))))))

(add-boot-init!
 (lambda ()
   (add-secondary-gc-daemon! clean-obarray)))

(define (impurify object)
  object)

(define (fasdump object filename #!optional quiet? dump-option)
  (let ((filename (->namestring (merge-pathnames filename)))
	(quiet? (if (default-object? quiet?) #f quiet?))
	(dump-option (if (default-object? dump-option) #f dump-option)))
    (let ((do-it
	   (lambda ()
	     (let loop ()
	       (if (not ((ucode-primitive primitive-fasdump)
			 object (string-for-primitive filename) dump-option))
		   (begin
		     (with-simple-restart 'retry "Try again."
		       (lambda ()
			 (error "FASDUMP: Object is too large to be dumped:"
				object)))
		     (loop)))))))
    (if quiet?
	(do-it)
	(with-notification (lambda (port)
			     (write-string "Dumping " port)
			     (write (enough-namestring filename) port))
	  do-it)))))

;;;; Hook lists

(define-record-type <hook-list>
    (%make-hook-list hooks)
    hook-list?
  (hooks hook-list-hooks set-hook-list-hooks!))

(define (make-hook-list)
  (%make-hook-list '()))

(define (append-hook-to-list hook-list key hook)
  (guarantee hook-list? hook-list 'append-hook-to-list)
  (let loop ((alist (hook-list-hooks hook-list)) (prev #f))
    (if (pair? alist)
	(loop (cdr alist)
	      (if (eq? (caar alist) key)
		  (begin
		    (if prev
			(set-cdr! prev (cdr alist))
			(set-hook-list-hooks! hook-list (cdr alist)))
		    prev)
		  alist))
	(let ((tail (list (cons key hook))))
	  (if prev
	      (set-cdr! prev tail)
	      (set-hook-list-hooks! hook-list tail))))))

(define (remove-hook-from-list hook-list key)
  (guarantee hook-list? hook-list 'remove-hook-from-list)
  (let loop ((alist (hook-list-hooks hook-list)) (prev #f))
    (if (pair? alist)
	(loop (cdr alist)
	      (if (eq? (caar alist) key)
		  (begin
		    (if prev
			(set-cdr! prev (cdr alist))
			(set-hook-list-hooks! hook-list (cdr alist)))
		    prev)
		  alist)))))

(define (hook-in-list? hook-list key)
  (guarantee hook-list? hook-list 'hook-in-list?)
  (if (assq key (hook-list-hooks hook-list)) #t #f))

(define (run-hooks-in-list hook-list . arguments)
  (guarantee hook-list? hook-list 'run-hooks-in-list)
  (for-each (lambda (p)
	      (apply (cdr p) arguments))
	    (hook-list-hooks hook-list)))

;;;; Metadata tables

(define metadata-table?
  (make-bundle-predicate 'metadata-table))

(define (make-alist-metadata-table)
  (let ((table (weak-alist-table eqv?)))

    (define (has? key)
      (weak-alist-table-contains? table key))

    (define (get key #!optional default-value)
      (weak-alist-table-ref table key
			    (if (default-object? default-value)
				default-value
				(lambda () default-value))))

    (define (put! key metadata)
      (weak-alist-table-set! table key metadata))

    (define (intern! key get-value)
      (weak-alist-table-intern! table key get-value))

    (define (delete! key)
      (weak-alist-table-delete! table key table))

    (define (get-alist)
      (weak-alist-table->alist table))

    (define (put-alist! alist)
      (for-each (lambda (p) (put! (car p) (cdr p))) alist))

    (define (get-keys)
      (weak-alist-table-keys table))

    (define (clear!)
      (weak-alist-table-clear! table))

    (bundle metadata-table? has? get put! intern! delete! get-alist put-alist!
	    get-keys clear!)))

(define (make-hashed-metadata-table)
  (let ((table (make-key-weak-eqv-hash-table)))

    (define (has? key)
      (hash-table-exists? table key))

    (define (get key #!optional default-value)
      (hash-table-ref table key
		      (if (default-object? default-value)
			  default-value
			  (lambda () default-value))))

    (define (put! key metadata)
      (hash-table-set! table key metadata))

    (define (intern! key get-value)
      (hash-table-intern! table key get-value))

    (define (delete! key)
      (hash-table-delete! table key))

    (define (get-alist)
      (hash-table->alist table))

    (define (put-alist! alist*)
      (for-each (lambda (p) (put! (car p) (cdr p))) alist*))

    (define (get-keys)
      (hash-table-values table))

    (define (clear!)
      (hash-table-clear! table))

    (bundle metadata-table? has? get put! intern! delete! get-alist put-alist!
	    get-keys clear!)))

;;;; Builder for vector-like sequences

(define (make-sequence-builder elt? seq? make-seq seq-length seq-set! seq-copy!
			       buffer-length)
  (let ((buffers)
	(buffer)
	(start)
	(index)
	(count))

    (define (reset!)
      (set! buffers '())
      (set! buffer (make-seq buffer-length))
      (set! start 0)
      (set! index 0)
      (set! count 0)
      unspecific)

    (define (append-elt! elt)
      (seq-set! buffer index elt)
      (set! index (fix:+ index 1))
      (set! count (fix:+ count 1))
      (if (not (fix:< index buffer-length))
	  (begin
	    (set! buffers (cons (get-partial) buffers))
	    (set! buffer (make-seq buffer-length))
	    (set! start 0)
	    (set! index 0)
	    unspecific)))

    (define (append-seq! seq)
      (let ((length (seq-length seq)))
	(if (fix:> length 0)
	    (begin
	      (if (fix:> index start)
		  (begin
		    (set! buffers (cons (get-partial) buffers))
		    (set! start index)))
	      (set! buffers (cons (vector seq 0 length) buffers))
	      (set! count (fix:+ count length))
	      unspecific))))

    (define (build)
      (let ((result (make-seq count)))
	(do ((parts (reverse
		     (if (fix:> index start)
			 (cons (get-partial) buffers)
			 buffers))
		    (cdr parts))
	     (i 0
		(let ((v (car parts)))
		  (let ((start (vector-ref v 1))
			(end (vector-ref v 2)))
		  (seq-copy! result i (vector-ref v 0) start end)
		  (fix:+ i (fix:- end start))))))
	    ((not (pair? parts))))
	result))

    (define (get-partial)
      (vector buffer start index))

    (reset!)
    (lambda (#!optional object)
      (cond ((default-object? object) (build))
	    ((elt? object) (append-elt! object))
	    ((seq? object) (append-seq! object))
	    (else
	     (case object
	       ((empty?) (fix:= count 0))
	       ((count) count)
	       ((reset!) (reset!))
	       (else (error "Unsupported argument:" object))))))))

;;;; Ephemerons

;;; The layout of an ephemeron is as follows:
;;;
;;;   0 vector (marked or non-marked) manifest
;;;   1 key
;;;   2 datum
;;;   3 extra
;;;   .  slots
;;;   .    for
;;;   .      GC

(define canonical-false (list 'false))

(define (canonicalize object)
  (if (eq? object #f)
      canonical-false
      object))

(define (decanonicalize object)
  (if (eq? object canonical-false)
      #f
      object))

(define (make-ephemeron key datum)
  ((ucode-primitive make-ephemeron 2) (canonicalize key) (canonicalize datum)))

(define (ephemeron? object)
  (object-type? (ucode-type ephemeron) object))

(define-guarantee ephemeron "ephemeron")

(define (ephemeron-key ephemeron)
  (guarantee-ephemeron ephemeron 'ephemeron-key)
  (decanonicalize (primitive-object-ref ephemeron 1)))

(define (ephemeron-datum ephemeron)
  (guarantee-ephemeron ephemeron 'ephemeron-datum)
  (decanonicalize (primitive-object-ref ephemeron 2)))

(define (set-ephemeron-key! ephemeron key)
  (guarantee-ephemeron ephemeron 'set-ephemeron-key!)
  (let ((key* (primitive-object-ref ephemeron 1)))
    (if key* (primitive-object-set! ephemeron 1 (canonicalize key)))
    (reference-barrier key*))
  unspecific)

(define (set-ephemeron-datum! ephemeron datum)
  (guarantee-ephemeron ephemeron 'set-ephemeron-datum!)
  (let ((key (primitive-object-ref ephemeron 1)))
    (if key (primitive-object-set! ephemeron 2 (canonicalize datum)))
    (reference-barrier key))
  unspecific)

(define (ephemeron-broken? ephemeron)
  (guarantee-ephemeron ephemeron 'ephemeron-broken?)
  (not (primitive-object-ref ephemeron 1)))

;;;; Partitioning

(define (partition-generator classifier comparator kons knil . options)
  (let ((cls= (comparator-equality-predicate comparator)))

    (define (impl:hybrid)
      (let ((alist-type (impl:mutable-alist))
	    (hash-table-type (impl:hash-table)))
	(lambda (items)
	  (if (fix:<= (length items) 128)
	      (alist-type items)
	      (hash-table-type items)))))

    (define (impl:immutable-alist)
      (alist-type alist-adjoiner))

    (define (impl:mutable-alist)
      (alist-type alist-adjoiner!))

    (define (alist-type alist-adjoiner)
      (let ((adjoiner (alist-adjoiner cls= kons knil)))
	(lambda (items)
	  (let ((alist
		 (fold (lambda (item alist)
			 (adjoiner (classifier item) item alist))
		       '()
		       items)))
	    (lambda (#!optional cls)
	      (if (default-object? cls)
		  (map car alist)
		  (let ((p (assoc cls alist cls=)))
		    (if p
			(cdr p)
			knil))))))))

    (define (impl:hash-table)
      (let ((knil-thunk (lambda () knil)))
	(lambda (items)
	  (let ((table (make-hash-table comparator)))
	    (for-each (lambda (item)
			(hash-table-update! table
					    (classifier item)
					    kons
					    knil-thunk))
		      items)
	    (lambda (#!optional cls)
	      (if (default-object? cls)
		  (hash-table-keys table)
		  (hash-table-ref table cls knil-thunk)))))))

    (let-values (((implementation)
		  (partition-generator-options options 'partition-generator)))
      (case implementation
	((#!default hybrid) (impl:hybrid))
	((immutable-alist) (impl:immutable-alist))
	((mutable-alist) (impl:mutable-alist))
	((hash-table) (impl:hash-table))
	(else (error "Unsupported implementation:" implementation))))))


(define partition-generator-options
  (keyword-option-parser
   (list (list 'implementation
	       '(hybrid immutable-alist mutable-alist hash-table)
	       'hybrid))))