[bpt/guile.git] / module / language / cps / compile-bytecode.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; Compiling CPS to bytecode.  The result is in the bytecode language,
;;; which happens to be an ELF image as a bytecode.
;;;
;;; Code:

(define-module (language cps compile-bytecode)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (language cps)
  #:use-module (language cps arities)
  #:use-module (language cps closure-conversion)
  #:use-module (language cps contification)
  #:use-module (language cps constructors)
  #:use-module (language cps dce)
  #:use-module (language cps dfg)
  #:use-module (language cps elide-values)
  #:use-module (language cps primitives)
  #:use-module (language cps reify-primitives)
  #:use-module (language cps simplify)
  #:use-module (language cps slot-allocation)
  #:use-module (language cps specialize-primcalls)
  #:use-module (system vm assembler)
  #:export (compile-bytecode))

;; TODO: Local var names.

(define (kw-arg-ref args kw default)
  (match (memq kw args)
    ((_ val . _) val)
    (_ default)))

(define (optimize exp opts)
  (define (run-pass exp pass kw default)
    (if (kw-arg-ref opts kw default)
        (pass exp)
        exp))

  ;; The first DCE pass is mainly to eliminate functions that aren't
  ;; called.  The last is mainly to eliminate rest parameters that
  ;; aren't used, and thus shouldn't be consed.

  (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
         (exp (run-pass exp simplify #:simplify? #t))
         (exp (run-pass exp contify #:contify? #t))
         (exp (run-pass exp inline-constructors #:inline-constructors? #t))
         (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
         (exp (run-pass exp elide-values #:elide-values? #t))
         (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
         (exp (run-pass exp simplify #:simplify? #t)))
    ;; Passes that are needed:
    ;; 
    ;;  * Abort contification: turning abort primcalls into continuation
    ;;    calls, and eliding prompts if possible.
    ;;
    ;;  * Common subexpression elimination.  Desperately needed.
    ;;
    ;;  * Loop peeling.  Unrolls the first round through a loop if the
    ;;    loop has effects that CSE can work on.  Requires effects
    ;;    analysis.  When run before CSE, loop peeling is the equivalent
    ;;    of loop-invariant code motion (LICM).

    exp))

(define (collect-conts f cfa)
  (let ((contv (make-vector (cfa-k-count cfa) #f)))
    (fold-local-conts
     (lambda (k cont tail)
       (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
         (when idx
           (vector-set! contv idx cont))))
     '()
     (match f
       (($ $fun src meta free entry)
        entry)))
    contv))

(define (compile-fun f asm)
  (let* ((dfg (compute-dfg f #:global? #f))
         (cfa (analyze-control-flow f dfg))
         (allocation (allocate-slots f dfg))
         (contv (collect-conts f cfa)))
    (define (lookup-cont k)
      (vector-ref contv (cfa-k-idx cfa k)))

    (define (maybe-slot sym)
      (lookup-maybe-slot sym allocation))

    (define (slot sym)
      (lookup-slot sym allocation))

    (define (constant sym)
      (lookup-constant-value sym allocation))

    (define (maybe-mov dst src)
      (unless (= dst src)
        (emit-mov asm dst src)))

    (define (maybe-load-constant slot src)
      (call-with-values (lambda ()
                          (lookup-maybe-constant-value src allocation))
        (lambda (has-const? val)
          (and has-const?
               (begin
                 (emit-load-constant asm slot val)
                 #t)))))

    (define (compile-entry meta)
      (match (vector-ref contv 0)
        (($ $kentry self tail clauses)
         (emit-begin-program asm (cfa-k-sym cfa 0) meta)
         (let lp ((n 1)
                  (ks (map (match-lambda (($ $cont k) k)) clauses)))
           (match ks
             (()
              (unless (= n (vector-length contv))
                (error "unexpected end of clauses"))
              (emit-end-program asm))
             ((k . ks)
              (unless (eq? (cfa-k-sym cfa n) k)
                (error "unexpected k" k))
              (lp (compile-clause n (and (pair? ks) (car ks)))
                  ks)))))))

    (define (compile-clause n alternate)
      (match (vector-ref contv n)
        (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
         (let* ((kw-indices (map (match-lambda
                                  ((key name sym)
                                   (cons key (lookup-slot sym allocation))))
                                 kw))
                (k (cfa-k-sym cfa n))
                (nlocals (lookup-nlocals k allocation)))
           (emit-label asm k)
           (emit-begin-kw-arity asm req opt rest kw-indices
                                allow-other-keys? nlocals alternate)
           (let ((next (compile-body (1+ n) nlocals)))
             (emit-end-arity asm)
             next)))))

    (define (compile-body n nlocals)
      (let compile-cont ((n n))
        (if (= n (vector-length contv))
            n
            (match (vector-ref contv n)
              (($ $kclause) n)
              (($ $kargs _ _ term)
               (emit-label asm (cfa-k-sym cfa n))
               (let find-exp ((term term))
                 (match term
                   (($ $letk conts term)
                    (find-exp term))
                   (($ $continue k src exp)
                    (when src
                      (emit-source asm src))
                    (compile-expression n k exp nlocals)
                    (compile-cont (1+ n))))))
              (_
               (emit-label asm (cfa-k-sym cfa n))
               (compile-cont (1+ n)))))))

    (define (compile-expression n k exp nlocals)
      (let* ((label (cfa-k-sym cfa n))
             (k-idx (cfa-k-idx cfa k))
             (fallthrough? (= k-idx (1+ n))))
        (define (maybe-emit-jump)
          (unless (= k-idx (1+ n))
            (emit-br asm k)))
        (match (vector-ref contv k-idx)
          (($ $ktail)
           (compile-tail label exp))
          (($ $kargs (name) (sym))
           (let ((dst (maybe-slot sym)))
             (when dst
               (compile-value label exp dst nlocals)))
           (maybe-emit-jump))
          (($ $kargs () ())
           (compile-effect label exp k nlocals)
           (maybe-emit-jump))
          (($ $kargs names syms)
           (compile-values label exp syms)
           (maybe-emit-jump))
          (($ $kif kt kf)
           (compile-test label exp kt kf
                         (and (= k-idx (1+ n))
                              (< (+ n 2) (cfa-k-count cfa))
                              (cfa-k-sym cfa (+ n 2)))))
          (($ $kreceive ($ $arity req () rest () #f) kargs)
           (compile-trunc label k exp (length req)
                          (and rest
                               (match (vector-ref contv (cfa-k-idx cfa kargs))
                                 (($ $kargs names (_ ... rest)) rest)))
                          nlocals)
           (unless (and (= k-idx (1+ n))
                        (< (+ n 2) (cfa-k-count cfa))
                        (eq? (cfa-k-sym cfa (+ n 2)) kargs))
             (emit-br asm kargs))))))

    (define (compile-tail label exp)
      ;; There are only three kinds of expressions in tail position:
      ;; tail calls, multiple-value returns, and single-value returns.
      (match exp
        (($ $call proc args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each maybe-load-constant tail-slots args))
         (emit-tail-call asm (1+ (length args))))
        (($ $values ())
         (emit-reset-frame asm 1)
         (emit-return-values asm))
        (($ $values (arg))
         (if (maybe-slot arg)
             (emit-return asm (slot arg))
             (begin
               (emit-load-constant asm 1 (constant arg))
               (emit-return asm 1))))
        (($ $values args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each maybe-load-constant tail-slots args))
         (emit-reset-frame asm (1+ (length args)))
         (emit-return-values asm))
        (($ $primcall 'return (arg))
         (emit-return asm (slot arg)))))

    (define (compile-value label exp dst nlocals)
      (match exp
        (($ $values (arg))
         (or (maybe-load-constant dst arg)
             (maybe-mov dst (slot arg))))
        (($ $void)
         (emit-load-constant asm dst *unspecified*))
        (($ $const exp)
         (emit-load-constant asm dst exp))
        (($ $fun src meta () ($ $cont k))
         (emit-load-static-procedure asm dst k))
        (($ $fun src meta free ($ $cont k))
         (emit-make-closure asm dst k (length free)))
        (($ $primcall 'current-module)
         (emit-current-module asm dst))
        (($ $primcall 'cached-toplevel-box (scope name bound?))
         (emit-cached-toplevel-box asm dst (constant scope) (constant name)
                                   (constant bound?)))
        (($ $primcall 'cached-module-box (mod name public? bound?))
         (emit-cached-module-box asm dst (constant mod) (constant name)
                                 (constant public?) (constant bound?)))
        (($ $primcall 'resolve (name bound?))
         (emit-resolve asm dst (constant bound?) (slot name)))
        (($ $primcall 'free-ref (closure idx))
         (emit-free-ref asm dst (slot closure) (constant idx)))
        (($ $primcall 'vector-ref (vector index))
         (emit-vector-ref asm dst (slot vector) (slot index)))
        (($ $primcall 'make-vector/immediate (length init))
         (emit-make-vector/immediate asm dst (constant length) (slot init)))
        (($ $primcall 'vector-ref/immediate (vector index))
         (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
        (($ $primcall 'allocate-struct/immediate (vtable nfields))
         (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
        (($ $primcall 'struct-ref/immediate (struct n))
         (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
        (($ $primcall 'builtin-ref (name))
         (emit-builtin-ref asm dst (constant name)))
        (($ $primcall 'bv-u8-ref (bv idx))
         (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s8-ref (bv idx))
         (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u16-ref (bv idx))
         (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s16-ref (bv idx))
         (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u32-ref (bv idx val))
         (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s32-ref (bv idx val))
         (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u64-ref (bv idx val))
         (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s64-ref (bv idx val))
         (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-f32-ref (bv idx val))
         (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-f64-ref (bv idx val))
         (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall name args)
         ;; FIXME: Inline all the cases.
         (let ((inst (prim-instruction name)))
           (emit-text asm `((,inst ,dst ,@(map slot args))))))))

    (define (compile-effect label exp k nlocals)
      (match exp
        (($ $values ()) #f)
        (($ $prompt escape? tag handler)
         (match (lookup-cont handler)
           (($ $kreceive ($ $arity req () rest () #f) khandler-body)
            (let ((receive-args (gensym "handler"))
                  (nreq (length req))
                  (proc-slot (lookup-call-proc-slot handler allocation)))
              (emit-prompt asm (slot tag) escape? proc-slot receive-args)
              (emit-br asm k)
              (emit-label asm receive-args)
              (unless (and rest (zero? nreq))
                (emit-receive-values asm proc-slot (->bool rest) nreq))
              (when (and rest
                         (match (vector-ref contv (cfa-k-idx cfa khandler-body))
                           (($ $kargs names (_ ... rest))
                            (maybe-slot rest))))
                (emit-bind-rest asm (+ proc-slot 1 nreq)))
              (for-each (match-lambda
                         ((src . dst) (emit-mov asm dst src)))
                        (lookup-parallel-moves handler allocation))
              (emit-reset-frame asm nlocals)
              (emit-br asm khandler-body)))))
        (($ $primcall 'cache-current-module! (sym scope))
         (emit-cache-current-module! asm (slot sym) (constant scope)))
        (($ $primcall 'free-set! (closure idx value))
         (emit-free-set! asm (slot closure) (slot value) (constant idx)))
        (($ $primcall 'box-set! (box value))
         (emit-box-set! asm (slot box) (slot value)))
        (($ $primcall 'struct-set!/immediate (struct index value))
         (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
        (($ $primcall 'vector-set! (vector index value))
         (emit-vector-set! asm (slot vector) (slot index) (slot value)))
        (($ $primcall 'vector-set!/immediate (vector index value))
         (emit-vector-set!/immediate asm (slot vector) (constant index)
                                     (slot value)))
        (($ $primcall 'variable-set! (var val))
         (emit-box-set! asm (slot var) (slot val)))
        (($ $primcall 'set-car! (pair value))
         (emit-set-car! asm (slot pair) (slot value)))
        (($ $primcall 'set-cdr! (pair value))
         (emit-set-cdr! asm (slot pair) (slot value)))
        (($ $primcall 'define! (sym value))
         (emit-define! asm (slot sym) (slot value)))
        (($ $primcall 'push-fluid (fluid val))
         (emit-push-fluid asm (slot fluid) (slot val)))
        (($ $primcall 'pop-fluid ())
         (emit-pop-fluid asm))
        (($ $primcall 'wind (winder unwinder))
         (emit-wind asm (slot winder) (slot unwinder)))
        (($ $primcall 'bv-u8-set! (bv idx val))
         (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s8-set! (bv idx val))
         (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u16-set! (bv idx val))
         (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s16-set! (bv idx val))
         (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u32-set! (bv idx val))
         (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s32-set! (bv idx val))
         (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u64-set! (bv idx val))
         (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s64-set! (bv idx val))
         (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-f32-set! (bv idx val))
         (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-f64-set! (bv idx val))
         (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'unwind ())
         (emit-unwind asm))))

    (define (compile-values label exp syms)
      (match exp
        (($ $values args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (for-each maybe-load-constant (map slot syms) args))))

    (define (compile-test label exp kt kf next-label)
      (define (unary op sym)
        (cond
         ((eq? kt next-label)
          (op asm (slot sym) #t kf))
         (else
          (op asm (slot sym) #f kt)
          (unless (eq? kf next-label)
            (emit-br asm kf)))))
      (define (binary op a b)
        (cond
         ((eq? kt next-label)
          (op asm (slot a) (slot b) #t kf))
         (else
          (op asm (slot a) (slot b) #f kt)
          (unless (eq? kf next-label)
            (emit-br asm kf)))))
      (match exp
        (($ $values (sym))
         (call-with-values (lambda ()
                             (lookup-maybe-constant-value sym allocation))
           (lambda (has-const? val)
             (if has-const?
                 (if val
                     (unless (eq? kt next-label)
                       (emit-br asm kt))
                     (unless (eq? kf next-label)
                       (emit-br asm kf)))
                 (unary emit-br-if-true sym)))))
        (($ $primcall 'null? (a)) (unary emit-br-if-null a))
        (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
        (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
        (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
        (($ $primcall 'char? (a)) (unary emit-br-if-char a))
        (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
        (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
        (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
        (($ $primcall 'string? (a)) (unary emit-br-if-string a))
        (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
        ;; Add more TC7 tests here.  Keep in sync with
        ;; *branching-primcall-arities* in (language cps primitives) and
        ;; the set of macro-instructions in assembly.scm.
        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
        (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
        (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
        (($ $primcall '< (a b)) (binary emit-br-if-< a b))
        (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
        (($ $primcall '= (a b)) (binary emit-br-if-= a b))
        (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
        (($ $primcall '> (a b)) (binary emit-br-if-< b a))))

    (define (compile-trunc label k exp nreq rest-var nlocals)
      (match exp
        (($ $call proc args)
         (let* ((proc-slot (lookup-call-proc-slot label allocation))
                (nargs (1+ (length args)))
                (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
           (for-each (match-lambda
                      ((src . dst) (emit-mov asm dst src)))
                     (lookup-parallel-moves label allocation))
           (for-each maybe-load-constant arg-slots (cons proc args))
           (emit-call asm proc-slot nargs)
           (cond
            ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
                  (match (lookup-parallel-moves k allocation)
                    ((((? (lambda (src) (= src (1+ proc-slot))) src)
                       . dst)) dst)
                    (_ #f)))
             ;; The usual case: one required live return value, ignoring
             ;; any additional values.
             => (lambda (dst)
                  (emit-receive asm dst proc-slot nlocals)))
            (else
             (unless (and (zero? nreq) rest-var)
               (emit-receive-values asm proc-slot (->bool rest-var) nreq))
             (when (and rest-var (maybe-slot rest-var))
               (emit-bind-rest asm (+ proc-slot 1 nreq)))
             (for-each (match-lambda
                        ((src . dst) (emit-mov asm dst src)))
                       (lookup-parallel-moves k allocation))
             (emit-reset-frame asm nlocals)))))))

    (match f
      (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
       ;; FIXME: src on kentry instead?
       (when src
         (emit-source asm src))
       (compile-entry (or meta '()))))))

(define (visit-funs proc exp)
  (match exp
    (($ $continue _ _ exp)
     (visit-funs proc exp))

    (($ $fun src meta free body)
     (proc exp)
     (visit-funs proc body))

    (($ $letk conts body)
     (visit-funs proc body)
     (for-each (lambda (cont) (visit-funs proc cont)) conts))

    (($ $cont sym ($ $kargs names syms body))
     (visit-funs proc body))

    (($ $cont sym ($ $kclause arity body))
     (visit-funs proc body))

    (($ $cont sym ($ $kentry self tail clauses))
     (for-each (lambda (clause) (visit-funs proc clause)) clauses))

    (_ (values))))

(define (compile-bytecode exp env opts)
  (let* ((exp (fix-arities exp))
         (exp (optimize exp opts))
         (exp (convert-closures exp))
         (exp (reify-primitives exp))
         (asm (make-assembler)))
    (visit-funs (lambda (fun)
                  (compile-fun fun asm))
                exp)
    (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
            env
            env)))
Commit	Line	Data
6e8ad823 AW	1	;;; Continuation-passing style (CPS) intermediate language (IL)
6e8ad823 AW	2
7ab76a83	3	;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
6e8ad823 AW	4
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	;;; Commentary:
	20	;;;
691697de AW	21	;;; Compiling CPS to bytecode. The result is in the bytecode language,
691697de AW	22	;;; which happens to be an ELF image as a bytecode.
6e8ad823 AW	23	;;;
	24	;;; Code:
	25
691697de	26	(define-module (language cps compile-bytecode)
6e8ad823 AW	27	#:use-module (ice-9 match)
	28	#:use-module (srfi srfi-1)
	29	#:use-module (language cps)
	30	#:use-module (language cps arities)
	31	#:use-module (language cps closure-conversion)
8ac8e2df	32	#:use-module (language cps contification)
fa3b6e57	33	#:use-module (language cps constructors)
305cccb4	34	#:use-module (language cps dce)
6e8ad823	35	#:use-module (language cps dfg)
7e273b7a	36	#:use-module (language cps elide-values)
6e8ad823 AW	37	#:use-module (language cps primitives)
6e8ad823 AW	38	#:use-module (language cps reify-primitives)
22a79b55	39	#:use-module (language cps simplify)
6e8ad823	40	#:use-module (language cps slot-allocation)
4c906ad5	41	#:use-module (language cps specialize-primcalls)
6e8ad823	42	#:use-module (system vm assembler)
691697de	43	#:export (compile-bytecode))
6e8ad823	44
d258fccc	45	;; TODO: Local var names.
6e8ad823 AW	46
	47	(define (kw-arg-ref args kw default)
	48	(match (memq kw args)
	49	((_ val . _) val)
	50	(_ default)))
	51
	52	(define (optimize exp opts)
	53	(define (run-pass exp pass kw default)
	54	(if (kw-arg-ref opts kw default)
1d15832f	55	(pass exp)
6e8ad823 AW	56	exp))
6e8ad823 AW	57
305cccb4 AW	58	;; The first DCE pass is mainly to eliminate functions that aren't
	59	;; called. The last is mainly to eliminate rest parameters that
	60	;; aren't used, and thus shouldn't be consed.
	61
	62	(let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
22a79b55	63	(exp (run-pass exp simplify #:simplify? #t))
305cccb4	64	(exp (run-pass exp contify #:contify? #t))
7e273b7a	65	(exp (run-pass exp inline-constructors #:inline-constructors? #t))
4c906ad5	66	(exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
305cccb4	67	(exp (run-pass exp elide-values #:elide-values? #t))
22a79b55 AW	68	(exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
22a79b55 AW	69	(exp (run-pass exp simplify #:simplify? #t)))
6e8ad823 AW	70	;; Passes that are needed:
6e8ad823 AW	71	;;
6e8ad823 AW	72	;; * Abort contification: turning abort primcalls into continuation
	73	;; calls, and eliding prompts if possible.
	74	;;
22a79b55	75	;; * Common subexpression elimination. Desperately needed.
6e8ad823 AW	76	;;
	77	;; * Loop peeling. Unrolls the first round through a loop if the
	78	;; loop has effects that CSE can work on. Requires effects
	79	;; analysis. When run before CSE, loop peeling is the equivalent
	80	;; of loop-invariant code motion (LICM).
6e8ad823 AW	81
	82	exp))
	83
d258fccc	84	(define (collect-conts f cfa)
6e422a35	85	(let ((contv (make-vector (cfa-k-count cfa) #f)))
d258fccc	86	(fold-local-conts
6e422a35	87	(lambda (k cont tail)
d258fccc AW	88	(let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
d258fccc AW	89	(when idx
d258fccc AW	90	(vector-set! contv idx cont))))
	91	'()
	92	(match f
6e422a35	93	(($ $fun src meta free entry)
d258fccc	94	entry)))
6e422a35	95	contv))
d258fccc AW	96
	97	(define (compile-fun f asm)
	98	(let* ((dfg (compute-dfg f #:global? #f))
	99	(cfa (analyze-control-flow f dfg))
6e422a35 AW	100	(allocation (allocate-slots f dfg))
	101	(contv (collect-conts f cfa)))
	102	(define (lookup-cont k)
	103	(vector-ref contv (cfa-k-idx cfa k)))
	104
987c1f5f AW	105	(define (maybe-slot sym)
	106	(lookup-maybe-slot sym allocation))
	107
6e422a35 AW	108	(define (slot sym)
	109	(lookup-slot sym allocation))
	110
	111	(define (constant sym)
	112	(lookup-constant-value sym allocation))
	113
	114	(define (maybe-mov dst src)
	115	(unless (= dst src)
	116	(emit-mov asm dst src)))
	117
	118	(define (maybe-load-constant slot src)
	119	(call-with-values (lambda ()
	120	(lookup-maybe-constant-value src allocation))
	121	(lambda (has-const? val)
	122	(and has-const?
	123	(begin
	124	(emit-load-constant asm slot val)
	125	#t)))))
	126
	127	(define (compile-entry meta)
	128	(match (vector-ref contv 0)
	129	(($ $kentry self tail clauses)
	130	(emit-begin-program asm (cfa-k-sym cfa 0) meta)
	131	(let lp ((n 1)
	132	(ks (map (match-lambda (($ $cont k) k)) clauses)))
	133	(match ks
	134	(()
	135	(unless (= n (vector-length contv))
	136	(error "unexpected end of clauses"))
	137	(emit-end-program asm))
	138	((k . ks)
	139	(unless (eq? (cfa-k-sym cfa n) k)
	140	(error "unexpected k" k))
	141	(lp (compile-clause n (and (pair? ks) (car ks)))
	142	ks)))))))
	143
	144	(define (compile-clause n alternate)
	145	(match (vector-ref contv n)
	146	(($ $kclause ($ $arity req opt rest kw allow-other-keys?))
	147	(let* ((kw-indices (map (match-lambda
	148	((key name sym)
	149	(cons key (lookup-slot sym allocation))))
	150	kw))
	151	(k (cfa-k-sym cfa n))
	152	(nlocals (lookup-nlocals k allocation)))
	153	(emit-label asm k)
	154	(emit-begin-kw-arity asm req opt rest kw-indices
	155	allow-other-keys? nlocals alternate)
	156	(let ((next (compile-body (1+ n) nlocals)))
	157	(emit-end-arity asm)
	158	next)))))
	159
	160	(define (compile-body n nlocals)
	161	(let compile-cont ((n n))
	162	(if (= n (vector-length contv))
	163	n
	164	(match (vector-ref contv n)
	165	(($ $kclause) n)
	166	(($ $kargs _ _ term)
	167	(emit-label asm (cfa-k-sym cfa n))
	168	(let find-exp ((term term))
	169	(match term
	170	(($ $letk conts term)
	171	(find-exp term))
172	(($ $continue k src exp)
173	(when src
174	(emit-source asm src))
175	(compile-expression n k exp nlocals)
176	(compile-cont (1+ n))))))
177	(_
178	(emit-label asm (cfa-k-sym cfa n))
179	(compile-cont (1+ n)))))))
180
181	(define (compile-expression n k exp nlocals)
182	(let* ((label (cfa-k-sym cfa n))
183	(k-idx (cfa-k-idx cfa k))
184	(fallthrough? (= k-idx (1+ n))))
185	(define (maybe-emit-jump)
186	(unless (= k-idx (1+ n))
187	(emit-br asm k)))
188	(match (vector-ref contv k-idx)
189	(($ $ktail)
190	(compile-tail label exp))
191	(($ $kargs (name) (sym))
987c1f5f	192	(let ((dst (maybe-slot sym)))
6e422a35 AW	193	(when dst
	194	(compile-value label exp dst nlocals)))
	195	(maybe-emit-jump))
	196	(($ $kargs () ())
	197	(compile-effect label exp k nlocals)
	198	(maybe-emit-jump))
	199	(($ $kargs names syms)
	200	(compile-values label exp syms)
	201	(maybe-emit-jump))
	202	(($ $kif kt kf)
	203	(compile-test label exp kt kf
	204	(and (= k-idx (1+ n))
	205	(< (+ n 2) (cfa-k-count cfa))
	206	(cfa-k-sym cfa (+ n 2)))))
36527695	207	(($ $kreceive ($ $arity req () rest () #f) kargs)
fa48a2f7 AW	208	(compile-trunc label k exp (length req)
	209	(and rest
	210	(match (vector-ref contv (cfa-k-idx cfa kargs))
	211	(($ $kargs names (_ ... rest)) rest)))
	212	nlocals)
6e422a35 AW	213	(unless (and (= k-idx (1+ n))
6e422a35 AW	214	(< (+ n 2) (cfa-k-count cfa))
987c1f5f AW	215	(eq? (cfa-k-sym cfa (+ n 2)) kargs))
987c1f5f AW	216	(emit-br asm kargs))))))
6e422a35 AW	217
	218	(define (compile-tail label exp)
	219	;; There are only three kinds of expressions in tail position:
	220	;; tail calls, multiple-value returns, and single-value returns.
	221	(match exp
	222	(($ $call proc args)
	223	(for-each (match-lambda
	224	((src . dst) (emit-mov asm dst src)))
	225	(lookup-parallel-moves label allocation))
	226	(let ((tail-slots (cdr (iota (1+ (length args))))))
	227	(for-each maybe-load-constant tail-slots args))
	228	(emit-tail-call asm (1+ (length args))))
987c1f5f AW	229	(($ $values ())
	230	(emit-reset-frame asm 1)
	231	(emit-return-values asm))
13085a82	232	(($ $values (arg))
987c1f5f	233	(if (maybe-slot arg)
13085a82 AW	234	(emit-return asm (slot arg))
	235	(begin
	236	(emit-load-constant asm 1 (constant arg))
	237	(emit-return asm 1))))
6e422a35	238	(($ $values args)
13085a82 AW	239	(for-each (match-lambda
	240	((src . dst) (emit-mov asm dst src)))
	241	(lookup-parallel-moves label allocation))
6e422a35	242	(let ((tail-slots (cdr (iota (1+ (length args))))))
6e422a35 AW	243	(for-each maybe-load-constant tail-slots args))
	244	(emit-reset-frame asm (1+ (length args)))
	245	(emit-return-values asm))
	246	(($ $primcall 'return (arg))
	247	(emit-return asm (slot arg)))))
	248
	249	(define (compile-value label exp dst nlocals)
	250	(match exp
6e422a35 AW	251	(($ $values (arg))
	252	(or (maybe-load-constant dst arg)
	253	(maybe-mov dst (slot arg))))
	254	(($ $void)
	255	(emit-load-constant asm dst unspecified))
	256	(($ $const exp)
	257	(emit-load-constant asm dst exp))
	258	(($ $fun src meta () ($ $cont k))
	259	(emit-load-static-procedure asm dst k))
	260	(($ $fun src meta free ($ $cont k))
	261	(emit-make-closure asm dst k (length free)))
6e422a35 AW	262	(($ $primcall 'current-module)
	263	(emit-current-module asm dst))
	264	(($ $primcall 'cached-toplevel-box (scope name bound?))
	265	(emit-cached-toplevel-box asm dst (constant scope) (constant name)
	266	(constant bound?)))
	267	(($ $primcall 'cached-module-box (mod name public? bound?))
	268	(emit-cached-module-box asm dst (constant mod) (constant name)
	269	(constant public?) (constant bound?)))
	270	(($ $primcall 'resolve (name bound?))
	271	(emit-resolve asm dst (constant bound?) (slot name)))
	272	(($ $primcall 'free-ref (closure idx))
	273	(emit-free-ref asm dst (slot closure) (constant idx)))
6e422a35	274	(($ $primcall 'vector-ref (vector index))
4c906ad5 AW	275	(emit-vector-ref asm dst (slot vector) (slot index)))
	276	(($ $primcall 'make-vector/immediate (length init))
	277	(emit-make-vector/immediate asm dst (constant length) (slot init)))
	278	(($ $primcall 'vector-ref/immediate (vector index))
	279	(emit-vector-ref/immediate asm dst (slot vector) (constant index)))
	280	(($ $primcall 'allocate-struct/immediate (vtable nfields))
	281	(emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
	282	(($ $primcall 'struct-ref/immediate (struct n))
	283	(emit-struct-ref/immediate asm dst (slot struct) (constant n)))
6e422a35 AW	284	(($ $primcall 'builtin-ref (name))
	285	(emit-builtin-ref asm dst (constant name)))
	286	(($ $primcall 'bv-u8-ref (bv idx))
	287	(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
d59060ce AW	288	(($ $primcall 'bv-s8-ref (bv idx))
d59060ce AW	289	(emit-bv-s8-ref asm dst (slot bv) (slot idx)))
6e422a35 AW	290	(($ $primcall 'bv-u16-ref (bv idx))
	291	(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
	292	(($ $primcall 'bv-s16-ref (bv idx))
	293	(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
	294	(($ $primcall 'bv-u32-ref (bv idx val))
	295	(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
	296	(($ $primcall 'bv-s32-ref (bv idx val))
	297	(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
	298	(($ $primcall 'bv-u64-ref (bv idx val))
	299	(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
	300	(($ $primcall 'bv-s64-ref (bv idx val))
	301	(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
	302	(($ $primcall 'bv-f32-ref (bv idx val))
	303	(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
	304	(($ $primcall 'bv-f64-ref (bv idx val))
	305	(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
	306	(($ $primcall name args)
	307	;; FIXME: Inline all the cases.
691697de	308	(let ((inst (prim-instruction name)))
6e422a35 AW	309	(emit-text asm `((,inst ,dst ,@(map slot args))))))))
	310
	311	(define (compile-effect label exp k nlocals)
	312	(match exp
	313	(($ $values ()) #f)
7ab76a83	314	(($ $prompt escape? tag handler)
6e422a35	315	(match (lookup-cont handler)
36527695	316	(($ $kreceive ($ $arity req () rest () #f) khandler-body)
6e422a35 AW	317	(let ((receive-args (gensym "handler"))
6e422a35 AW	318	(nreq (length req))
987c1f5f	319	(proc-slot (lookup-call-proc-slot handler allocation)))
6e422a35 AW	320	(emit-prompt asm (slot tag) escape? proc-slot receive-args)
	321	(emit-br asm k)
	322	(emit-label asm receive-args)
4dfcb360 AW	323	(unless (and rest (zero? nreq))
4dfcb360 AW	324	(emit-receive-values asm proc-slot (->bool rest) nreq))
fa48a2f7 AW	325	(when (and rest
	326	(match (vector-ref contv (cfa-k-idx cfa khandler-body))
	327	(($ $kargs names (_ ... rest))
	328	(maybe-slot rest))))
6e422a35 AW	329	(emit-bind-rest asm (+ proc-slot 1 nreq)))
	330	(for-each (match-lambda
	331	((src . dst) (emit-mov asm dst src)))
	332	(lookup-parallel-moves handler allocation))
	333	(emit-reset-frame asm nlocals)
	334	(emit-br asm khandler-body)))))
	335	(($ $primcall 'cache-current-module! (sym scope))
	336	(emit-cache-current-module! asm (slot sym) (constant scope)))
	337	(($ $primcall 'free-set! (closure idx value))
	338	(emit-free-set! asm (slot closure) (slot value) (constant idx)))
	339	(($ $primcall 'box-set! (box value))
	340	(emit-box-set! asm (slot box) (slot value)))
4c906ad5 AW	341	(($ $primcall 'struct-set!/immediate (struct index value))
4c906ad5 AW	342	(emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
6e422a35	343	(($ $primcall 'vector-set! (vector index value))
4c906ad5 AW	344	(emit-vector-set! asm (slot vector) (slot index) (slot value)))
	345	(($ $primcall 'vector-set!/immediate (vector index value))
	346	(emit-vector-set!/immediate asm (slot vector) (constant index)
	347	(slot value)))
6e422a35 AW	348	(($ $primcall 'variable-set! (var val))
	349	(emit-box-set! asm (slot var) (slot val)))
	350	(($ $primcall 'set-car! (pair value))
	351	(emit-set-car! asm (slot pair) (slot value)))
	352	(($ $primcall 'set-cdr! (pair value))
	353	(emit-set-cdr! asm (slot pair) (slot value)))
	354	(($ $primcall 'define! (sym value))
	355	(emit-define! asm (slot sym) (slot value)))
	356	(($ $primcall 'push-fluid (fluid val))
	357	(emit-push-fluid asm (slot fluid) (slot val)))
	358	(($ $primcall 'pop-fluid ())
	359	(emit-pop-fluid asm))
	360	(($ $primcall 'wind (winder unwinder))
	361	(emit-wind asm (slot winder) (slot unwinder)))
	362	(($ $primcall 'bv-u8-set! (bv idx val))
	363	(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
d59060ce AW	364	(($ $primcall 'bv-s8-set! (bv idx val))
d59060ce AW	365	(emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
6e422a35 AW	366	(($ $primcall 'bv-u16-set! (bv idx val))
	367	(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
	368	(($ $primcall 'bv-s16-set! (bv idx val))
	369	(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
	370	(($ $primcall 'bv-u32-set! (bv idx val))
	371	(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
	372	(($ $primcall 'bv-s32-set! (bv idx val))
	373	(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
	374	(($ $primcall 'bv-u64-set! (bv idx val))
	375	(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
	376	(($ $primcall 'bv-s64-set! (bv idx val))
	377	(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
	378	(($ $primcall 'bv-f32-set! (bv idx val))
	379	(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
	380	(($ $primcall 'bv-f64-set! (bv idx val))
	381	(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
	382	(($ $primcall 'unwind ())
	383	(emit-unwind asm))))
	384
	385	(define (compile-values label exp syms)
	386	(match exp
	387	(($ $values args)
	388	(for-each (match-lambda
	389	((src . dst) (emit-mov asm dst src)))
	390	(lookup-parallel-moves label allocation))
	391	(for-each maybe-load-constant (map slot syms) args))))
	392
	393	(define (compile-test label exp kt kf next-label)
	394	(define (unary op sym)
	395	(cond
	396	((eq? kt next-label)
	397	(op asm (slot sym) #t kf))
	398	(else
	399	(op asm (slot sym) #f kt)
	400	(unless (eq? kf next-label)
	401	(emit-br asm kf)))))
	402	(define (binary op a b)
	403	(cond
	404	((eq? kt next-label)
	405	(op asm (slot a) (slot b) #t kf))
	406	(else
	407	(op asm (slot a) (slot b) #f kt)
	408	(unless (eq? kf next-label)
	409	(emit-br asm kf)))))
	410	(match exp
58ef5f07 AW	411	(($ $values (sym))
	412	(call-with-values (lambda ()
	413	(lookup-maybe-constant-value sym allocation))
	414	(lambda (has-const? val)
	415	(if has-const?
	416	(if val
	417	(unless (eq? kt next-label)
	418	(emit-br asm kt))
	419	(unless (eq? kf next-label)
	420	(emit-br asm kf)))
	421	(unary emit-br-if-true sym)))))
6e422a35 AW	422	(($ $primcall 'null? (a)) (unary emit-br-if-null a))
	423	(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
	424	(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
	425	(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
	426	(($ $primcall 'char? (a)) (unary emit-br-if-char a))
	427	(($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
	428	(($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
	429	(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
	430	(($ $primcall 'string? (a)) (unary emit-br-if-string a))
	431	(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
	432	;; Add more TC7 tests here. Keep in sync with
	433	;; branching-primcall-arities in (language cps primitives) and
	434	;; the set of macro-instructions in assembly.scm.
	435	(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
	436	(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
	437	(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
	438	(($ $primcall '< (a b)) (binary emit-br-if-< a b))
	439	(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
	440	(($ $primcall '= (a b)) (binary emit-br-if-= a b))
	441	(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
	442	(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
	443
fa48a2f7	444	(define (compile-trunc label k exp nreq rest-var nlocals)
6e422a35 AW	445	(match exp
6e422a35 AW	446	(($ $call proc args)
987c1f5f AW	447	(let* ((proc-slot (lookup-call-proc-slot label allocation))
	448	(nargs (1+ (length args)))
	449	(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
	450	(for-each (match-lambda
	451	((src . dst) (emit-mov asm dst src)))
	452	(lookup-parallel-moves label allocation))
	453	(for-each maybe-load-constant arg-slots (cons proc args))
	454	(emit-call asm proc-slot nargs)
e4fa7d40 AW	455	(cond
	456	((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
	457	(match (lookup-parallel-moves k allocation)
	458	((((? (lambda (src) (= src (1+ proc-slot))) src)
	459	. dst)) dst)
	460	(_ #f)))
	461	;; The usual case: one required live return value, ignoring
	462	;; any additional values.
	463	=> (lambda (dst)
	464	(emit-receive asm dst proc-slot nlocals)))
	465	(else
97cfb467 AW	466	(unless (and (zero? nreq) rest-var)
97cfb467 AW	467	(emit-receive-values asm proc-slot (->bool rest-var) nreq))
e4fa7d40 AW	468	(when (and rest-var (maybe-slot rest-var))
	469	(emit-bind-rest asm (+ proc-slot 1 nreq)))
	470	(for-each (match-lambda
	471	((src . dst) (emit-mov asm dst src)))
	472	(lookup-parallel-moves k allocation))
	473	(emit-reset-frame asm nlocals)))))))
6e422a35 AW	474
	475	(match f
	476	(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
	477	;; FIXME: src on kentry instead?
	478	(when src
	479	(emit-source asm src))
	480	(compile-entry (or meta '()))))))
d258fccc	481
6e8ad823 AW	482	(define (visit-funs proc exp)
6e8ad823 AW	483	(match exp
6e422a35	484	(($ $continue _ _ exp)
6e8ad823 AW	485	(visit-funs proc exp))
6e8ad823 AW	486
6e422a35	487	(($ $fun src meta free body)
6e8ad823 AW	488	(proc exp)
	489	(visit-funs proc body))
	490
	491	(($ $letk conts body)
	492	(visit-funs proc body)
	493	(for-each (lambda (cont) (visit-funs proc cont)) conts))
	494
6e422a35	495	(($ $cont sym ($ $kargs names syms body))
6e8ad823 AW	496	(visit-funs proc body))
6e8ad823 AW	497
6e422a35	498	(($ $cont sym ($ $kclause arity body))
6e8ad823 AW	499	(visit-funs proc body))
6e8ad823 AW	500
6e422a35	501	(($ $cont sym ($ $kentry self tail clauses))
6e8ad823 AW	502	(for-each (lambda (clause) (visit-funs proc clause)) clauses))
	503
	504	(_ (values))))
	505
691697de	506	(define (compile-bytecode exp env opts)
6e8ad823 AW	507	(let* ((exp (fix-arities exp))
	508	(exp (optimize exp opts))
	509	(exp (convert-closures exp))
	510	(exp (reify-primitives exp))
	511	(asm (make-assembler)))
	512	(visit-funs (lambda (fun)
	513	(compile-fun fun asm))
	514	exp)
	515	(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
	516	env
	517	env)))