(herald compose
  (env tsys))

;;; Clever implementation of COMPOSE by binary reduction & LAP.
;;; Measurably faster than the `obvious' definition, which is what T
;;; uses.  To load this, type this incantation:
;;;
;;;   (bind (( ((*value orbit-env 'orbit-syntax-table))
;;;            (env-syntax-table t-implementation-env)))
;;;     (comfile 'compose))
;;;
;;;   (load 'compose)

(define (compose . fs)
  (if (null-list? fs)
      return
      (iterate loop ((fs (cdr fs)) (composition (car fs)))
        (if (null-list? fs)
            composition
            (loop (cdr fs)
                  (compose-2 (car fs) composition))))))

;; (define (compose-2 f g)
;;   (lambda (x)
;;     (receive-values f (lambda () (g x)))))

(define (compose-2 f g)
  (let ((extend (%make-extend composition-template 2)))
    (set (extend-elt extend 0) f)
    (set (extend-elt extend 1) g)
    extend))

(define composition-template
  (lap-template (2 1 '#t heap handle-composition)
    (sub ($ 8) SP)                      ; push continuation
    (store l link-reg (d@r SP 4))       ; save next continuation
    (store l P (d@r SP 0))              ; save F
    (load l (d@r P 2) P)                ; call G
    (load l (d@nil slink/icall) extra)
    (jalr extra)
    (add ($ template-return-offset) link-reg)
    (template 1 -1 '#t)
    (load l (d@r SP 0) P)               ; restore F
    (load l (d@r SP 4) link-reg)        ; restore next continuation
    (add ($ 8) SP)                      ; pop continuation
    (load l (d@r P 6) P)                ; call F with saved continuation
    (load l (d@nil slink/icall) extra)
    (jr extra)
    (sub NARGS zero NARGS)
handle-composition
    (jr link-reg)
    (move nil-reg AN)))