-;;; TREE-IL -> GLIL compiler
-
-;; Copyright (C) 2001,2008,2009 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
-
-;;; Code:
-
-(define-module (language tree-il compile-glil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (ice-9 receive)
- #:use-module (language glil)
- #:use-module (system vm instruction)
- #:use-module (language tree-il)
- #:use-module (language tree-il optimize)
- #:use-module (language tree-il analyze)
- #:export (compile-glil))
-
-;;; TODO:
-;;
-;; call-with-values -> mv-bind
-;; basic degenerate-case reduction
-
-;; allocation:
-;; sym -> {lambda -> address}
-;; lambda -> (nlocs . closure-vars)
-;;
-;; address := (local? boxed? . index)
-;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
-;; free variable addresses are relative to parent proc.
-
-(define *comp-module* (make-fluid))
-
-(define (compile-glil x e opts)
- (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
- (x (optimize! x e opts))
- (allocation (analyze-lexicals x)))
- (with-fluid* *comp-module* (or (and e (car e)) (current-module))
- (lambda ()
- (values (flatten-lambda x allocation)
- (and e (cons (car e) (cddr e)))
- e)))))
-
-\f
-
-(define *primcall-ops* (make-hash-table))
-(for-each
- (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
- '(((eq? . 2) . eq?)
- ((eqv? . 2) . eqv?)
- ((equal? . 2) . equal?)
- ((= . 2) . ee?)
- ((< . 2) . lt?)
- ((> . 2) . gt?)
- ((<= . 2) . le?)
- ((>= . 2) . ge?)
- ((+ . 2) . add)
- ((- . 2) . sub)
- ((* . 2) . mul)
- ((/ . 2) . div)
- ((quotient . 2) . quo)
- ((remainder . 2) . rem)
- ((modulo . 2) . mod)
- ((not . 1) . not)
- ((pair? . 1) . pair?)
- ((cons . 2) . cons)
- ((car . 1) . car)
- ((cdr . 1) . cdr)
- ((set-car! . 2) . set-car!)
- ((set-cdr! . 2) . set-cdr!)
- ((null? . 1) . null?)
- ((list? . 1) . list?)
- (list . list)
- (vector . vector)
- ((@slot-ref . 2) . slot-ref)
- ((@slot-set! . 3) . slot-set)
- ((vector-ref . 2) . vector-ref)
- ((vector-set! . 3) . vector-set)
-
- ((bytevector-u8-ref . 2) . bv-u8-ref)
- ((bytevector-u8-set! . 3) . bv-u8-set)
- ((bytevector-s8-ref . 2) . bv-s8-ref)
- ((bytevector-s8-set! . 3) . bv-s8-set)
-
- ((bytevector-u16-ref . 3) . bv-u16-ref)
- ((bytevector-u16-set! . 4) . bv-u16-set)
- ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
- ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
- ((bytevector-s16-ref . 3) . bv-s16-ref)
- ((bytevector-s16-set! . 4) . bv-s16-set)
- ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
- ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
-
- ((bytevector-u32-ref . 3) . bv-u32-ref)
- ((bytevector-u32-set! . 4) . bv-u32-set)
- ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
- ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
- ((bytevector-s32-ref . 3) . bv-s32-ref)
- ((bytevector-s32-set! . 4) . bv-s32-set)
- ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
- ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
-
- ((bytevector-u64-ref . 3) . bv-u64-ref)
- ((bytevector-u64-set! . 4) . bv-u64-set)
- ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
- ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
- ((bytevector-s64-ref . 3) . bv-s64-ref)
- ((bytevector-s64-set! . 4) . bv-s64-set)
- ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
- ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
-
- ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
- ((bytevector-ieee-single-set! . 4) . bv-f32-set)
- ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
- ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
- ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
- ((bytevector-ieee-double-set! . 4) . bv-f64-set)
- ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
- ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
-
-
-\f
-
-(define (make-label) (gensym ":L"))
-
-(define (vars->bind-list ids vars allocation proc)
- (map (lambda (id v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t ,boxed? . ,n)
- (list id boxed? n))
- (,x (error "badness" x))))
- ids
- vars))
-
-(define (emit-bindings src ids vars allocation proc emit-code)
- (if (pair? vars)
- (emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation proc)))))
-
-(define (with-output-to-code proc)
- (let ((out '()))
- (define (emit-code src x)
- (set! out (cons x out))
- (if src
- (set! out (cons (make-glil-source src) out))))
- (proc emit-code)
- (reverse out)))
-
-(define (flatten-lambda x allocation)
- (receive (ids vars nargs nrest)
- (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
- (oids '()) (ovars '()) (n 0))
- (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
- ((pair? vars) (lp (cdr ids) (cdr vars)
- (cons (car ids) oids) (cons (car vars) ovars)
- (1+ n)))
- (else (values (reverse (cons ids oids))
- (reverse (cons vars ovars))
- (1+ n) 1))))
- (let ((nlocs (car (hashq-ref allocation x))))
- (make-glil-program
- nargs nrest nlocs (lambda-meta x)
- (with-output-to-code
- (lambda (emit-code)
- ;; write bindings and source debugging info
- (emit-bindings #f ids vars allocation x emit-code)
- (if (lambda-src x)
- (emit-code #f (make-glil-source (lambda-src x))))
- ;; box args if necessary
- (for-each
- (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
- ;; and here, here, dear reader: we compile.
- (flatten (lambda-body x) allocation x emit-code)))))))
-
-(define (flatten x allocation proc emit-code)
- (define (emit-label label)
- (emit-code #f (make-glil-label label)))
- (define (emit-branch src inst label)
- (emit-code src (make-glil-branch inst label)))
-
- ;; LMVRA == "let-values MV return address"
- (let comp ((x x) (context 'tail) (LMVRA #f))
- (define (comp-tail tree) (comp tree context LMVRA))
- (define (comp-push tree) (comp tree 'push #f))
- (define (comp-drop tree) (comp tree 'drop #f))
- (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
-
- (record-case x
- ((<void>)
- (case context
- ((push vals) (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ((<const> src exp)
- (case context
- ((push vals) (emit-code src (make-glil-const exp)))
- ((tail)
- (emit-code src (make-glil-const exp))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> src exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
- (cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
- ((push)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args)))))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- LMVRA))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br LMVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values (length args))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- LMVRA))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (comp-push consumer)
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/args 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'goto/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- LMVRA))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1)))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)))))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail) (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))
- ((push vals) (emit-code #f (make-glil-void)))))
- ((1)
- (case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))
- ((drop) (emit-code #f (make-glil-call 'drop 1)))))
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
- (else
- (comp-push proc)
- (for-each comp-push args)
- (let ((len (length args)))
- (case context
- ((tail) (emit-code src (make-glil-call 'goto/args len)))
- ((push) (emit-code src (make-glil-call 'call len)))
- ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
- ((drop)
- (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br POST)
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind '() #f))
- (emit-code #f (make-glil-unbind))
- (emit-label POST))))))))
-
- ((<conditional> src test then else)
- ;; TEST
- ;; (br-if-not L1)
- ;; THEN
- ;; (br L2)
- ;; L1: ELSE
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- (comp-push test)
- (emit-branch src 'br-if-not L1)
- (comp-tail then)
- (if (not (eq? context 'tail))
- (emit-branch #f 'br L2))
- (emit-label L1)
- (comp-tail else)
- (if (not (eq? context 'tail))
- (emit-label L2))))
-
- ((<primitive-ref> src name)
- (cond
- ((eq? (module-variable (fluid-ref *comp-module*) name)
- (module-variable the-root-module name))
- (case context
- ((push vals)
- (emit-code src (make-glil-toplevel 'ref name)))
- ((tail)
- (emit-code src (make-glil-toplevel 'ref name))
- (emit-code #f (make-glil-call 'return 1)))))
- (else
- (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
- (case context
- ((push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f)))
- ((tail)
- (emit-code src (make-glil-module 'ref '(guile) name #f))
- (emit-code #f (make-glil-call 'return 1)))))))
-
- ((<lexical-ref> src name gensym)
- (case context
- ((push vals tail)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'ref index)))
- (,loc
- (error "badness" x loc)))))
- (case context
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
-
- ((<lexical-set> src name gensym exp)
- (comp-push exp)
- (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'set index)))
- (,loc
- (error "badness" x loc)))
- (case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ((<module-ref> src mod name public?)
- (emit-code src (make-glil-module 'ref mod name public?))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
-
- ((<module-set> src mod name public? exp)
- (comp-push exp)
- (emit-code src (make-glil-module 'set mod name public?))
- (case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ((<toplevel-ref> src name)
- (emit-code src (make-glil-toplevel 'ref name))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1)))
- ((tail) (emit-code #f (make-glil-call 'return 1)))))
-
- ((<toplevel-set> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'set name))
- (case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ((<toplevel-define> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'define name))
- (case context
- ((push vals)
- (emit-code #f (make-glil-void)))
- ((tail)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-call 'return 1)))))
-
- ((<lambda>)
- (let ((free-locs (cdr (hashq-ref allocation x))))
- (case context
- ((push vals tail)
- (emit-code #f (flatten-lambda x allocation))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "what" x loc))))
- free-locs)
- (emit-code #f (make-glil-call 'vector (length free-locs)))
- (emit-code #f (make-glil-call 'make-closure 2))))
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))))
-
- ((<let> src names vars vals body)
- (for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind)))
-
- ((<letrec> src names vars vals body)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'empty-box n)))
- (,loc (error "badness" x loc))))
- vars)
- (for-each comp-push vals)
- (emit-bindings src names vars allocation proc emit-code)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind)))
-
- ((<let-values> src names vars exp body)
- (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
- (cond
- ((pair? inames)
- (lp (cons (car inames) names) (cons (car ivars) vars)
- (cdr inames) (cdr ivars) #f))
- ((not (null? inames))
- (lp (cons inames names) (cons ivars vars) '() '() #t))
- (else
- (let ((names (reverse! names))
- (vars (reverse! vars))
- (MV (make-label)))
- (comp-vals exp MV)
- (emit-code #f (make-glil-const 1))
- (emit-label MV)
- (emit-code src (make-glil-mv-bind
- (vars->bind-list names vars allocation proc)
- rest?))
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
- (reverse vars))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))))))))
+;;; TREE-IL -> GLIL compiler
+
+;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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
+
+;;; Code:
+
+(define-module (language tree-il compile-glil)
+ #:use-module (system base syntax)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (ice-9 receive)
+ #:use-module (language glil)
+ #:use-module (system vm instruction)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il optimize)
+ #:use-module (language tree-il canonicalize)
+ #:use-module (language tree-il analyze)
+ #:use-module ((srfi srfi-1) #:select (filter-map))
+ #:export (compile-glil))
+
+;; allocation:
+;; sym -> {lambda -> address}
+;; lambda -> (labels . free-locs)
+;; lambda-case -> (gensym . nlocs)
+;;
+;; address ::= (local? boxed? . index)
+;; labels ::= ((sym . lambda) ...)
+;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
+;; free variable addresses are relative to parent proc.
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+ `((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
+
+(define (compile-glil x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
+
+ (let* ((x (make-lambda (tree-il-src x) '()
+ (make-lambda-case #f '() #f #f #f '() '() x #f)))
+ (x (optimize! x e opts))
+ (x (canonicalize! x))
+ (allocation (analyze-lexicals x)))
+
+ (with-fluids ((*comp-module* e))
+ (values (flatten-lambda x #f allocation)
+ e
+ e))))
+
+\f
+
+(define *primcall-ops* (make-hash-table))
+(for-each
+ (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
+ '(((eq? . 2) . eq?)
+ ((eqv? . 2) . eqv?)
+ ((equal? . 2) . equal?)
+ ((= . 2) . ee?)
+ ((< . 2) . lt?)
+ ((> . 2) . gt?)
+ ((<= . 2) . le?)
+ ((>= . 2) . ge?)
+ ((+ . 2) . add)
+ ((- . 2) . sub)
+ ((1+ . 1) . add1)
+ ((1- . 1) . sub1)
+ ((* . 2) . mul)
+ ((/ . 2) . div)
+ ((quotient . 2) . quo)
+ ((remainder . 2) . rem)
+ ((modulo . 2) . mod)
+ ((ash . 2) . ash)
+ ((logand . 2) . logand)
+ ((logior . 2) . logior)
+ ((logxor . 2) . logxor)
+ ((not . 1) . not)
+ ((pair? . 1) . pair?)
+ ((cons . 2) . cons)
+ ((car . 1) . car)
+ ((cdr . 1) . cdr)
+ ((set-car! . 2) . set-car!)
+ ((set-cdr! . 2) . set-cdr!)
+ ((null? . 1) . null?)
+ ((list? . 1) . list?)
+ ((symbol? . 1) . symbol?)
+ ((vector? . 1) . vector?)
+ ((nil? . 1) . nil?)
+ (list . list)
+ (vector . vector)
+ ((class-of . 1) . class-of)
+ ((@slot-ref . 2) . slot-ref)
+ ((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
+ ((vector-ref . 2) . vector-ref)
+ ((vector-set! . 3) . vector-set)
+ ((variable-ref . 1) . variable-ref)
+ ;; nb, *not* variable-set! -- the args are switched
+ ((variable-bound? . 1) . variable-bound?)
+ ((struct? . 1) . struct?)
+ ((struct-vtable . 1) . struct-vtable)
+ ((struct-ref . 2) . struct-ref)
+ ((struct-set! . 3) . struct-set)
+ (make-struct/no-tail . make-struct)
+
+ ;; hack for javascript
+ ((return . 1) . return)
+ ;; hack for lua
+ (return/values . return/values)
+
+ ((bytevector-u8-ref . 2) . bv-u8-ref)
+ ((bytevector-u8-set! . 3) . bv-u8-set)
+ ((bytevector-s8-ref . 2) . bv-s8-ref)
+ ((bytevector-s8-set! . 3) . bv-s8-set)
+
+ ((bytevector-u16-ref . 3) . bv-u16-ref)
+ ((bytevector-u16-set! . 4) . bv-u16-set)
+ ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
+ ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
+ ((bytevector-s16-ref . 3) . bv-s16-ref)
+ ((bytevector-s16-set! . 4) . bv-s16-set)
+ ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
+ ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
+
+ ((bytevector-u32-ref . 3) . bv-u32-ref)
+ ((bytevector-u32-set! . 4) . bv-u32-set)
+ ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
+ ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
+ ((bytevector-s32-ref . 3) . bv-s32-ref)
+ ((bytevector-s32-set! . 4) . bv-s32-set)
+ ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
+ ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
+
+ ((bytevector-u64-ref . 3) . bv-u64-ref)
+ ((bytevector-u64-set! . 4) . bv-u64-set)
+ ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
+ ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
+ ((bytevector-s64-ref . 3) . bv-s64-ref)
+ ((bytevector-s64-set! . 4) . bv-s64-set)
+ ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
+ ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
+
+ ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
+ ((bytevector-ieee-single-set! . 4) . bv-f32-set)
+ ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
+ ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
+ ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
+ ((bytevector-ieee-double-set! . 4) . bv-f64-set)
+ ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
+ ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
+
+
+\f
+
+(define (make-label) (gensym ":L"))
+
+(define (vars->bind-list ids vars allocation proc)
+ (map (lambda (id v)
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t ,boxed? . ,n)
+ (list id boxed? n))
+ (,x (error "bad var list element" id v x))))
+ ids
+ vars))
+
+(define (emit-bindings src ids vars allocation proc emit-code)
+ (emit-code src (make-glil-bind
+ (vars->bind-list ids vars allocation proc))))
+
+(define (with-output-to-code proc)
+ (let ((out '()))
+ (define (emit-code src x)
+ (set! out (cons x out))
+ (if src
+ (set! out (cons (make-glil-source src) out))))
+ (proc emit-code)
+ (reverse out)))
+
+(define (flatten-lambda x self-label allocation)
+ (record-case x
+ ((<lambda> src meta body)
+ (make-glil-program
+ meta
+ (with-output-to-code
+ (lambda (emit-code)
+ ;; write source info for proc
+ (if src (emit-code #f (make-glil-source src)))
+ ;; compile the body, yo
+ (flatten-lambda-case body allocation x self-label
+ (car (hashq-ref allocation x))
+ emit-code)))))))
+
+(define (flatten-lambda-case lcase allocation self self-label fix-labels
+ emit-code)
+ (define (emit-label label)
+ (emit-code #f (make-glil-label label)))
+ (define (emit-branch src inst label)
+ (emit-code src (make-glil-branch inst label)))
+
+ ;; RA: "return address"; #f unless we're in a non-tail fix with labels
+ ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
+ (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
+ (define (comp-tail tree) (comp tree context RA MVRA))
+ (define (comp-push tree) (comp tree 'push #f #f))
+ (define (comp-drop tree) (comp tree 'drop #f #f))
+ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
+ (define (comp-fix tree RA) (comp tree context RA MVRA))
+
+ ;; A couple of helpers. Note that if we are in tail context, we
+ ;; won't have an RA.
+ (define (maybe-emit-return)
+ (if RA
+ (emit-branch #f 'br RA)
+ (if (eq? context 'tail)
+ (emit-code #f (make-glil-call 'return 1)))))
+
+ ;; After lexical binding forms in non-tail context, call this
+ ;; function to clear stack slots, allowing their previous values to
+ ;; be collected.
+ (define (clear-stack-slots context syms)
+ (case context
+ ((push drop)
+ (for-each (lambda (v)
+ (and=>
+ ;; Can be #f if the var is labels-allocated.
+ (hashq-ref allocation v)
+ (lambda (h)
+ (pmatch (hashq-ref h self)
+ ((#t _ . ,n)
+ (emit-code #f (make-glil-void))
+ (emit-code #f (make-glil-lexical #t #f 'set n)))
+ (,loc (error "bad let var allocation" x loc))))))
+ syms))))
+
+ (record-case x
+ ((<void>)
+ (case context
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<const> src exp)
+ (case context
+ ((push vals tail)
+ (emit-code src (make-glil-const exp))))
+ (maybe-emit-return))
+
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
+ (cond
+ ;; call to the same lambda-case in tail position
+ ((and (lexical-ref? proc)
+ self-label (eq? (lexical-ref-gensym proc) self-label)
+ (eq? context 'tail)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args)
+ (+ (length (lambda-case-req lcase))
+ (or (and=> (lambda-case-opt lcase) length) 0))))
+ (for-each comp-push args)
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ ;; new box
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "bad lambda-case arg allocation" x))))
+ (reverse (lambda-case-gensyms lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+
+ ;; lambda, the ultimate goto
+ ((and (lexical-ref? proc)
+ (assq (lexical-ref-gensym proc) fix-labels))
+ ;; like the self-tail-call case, though we can handle "drop"
+ ;; contexts too. first, evaluate new values, pushing them on
+ ;; the stack
+ (for-each comp-push args)
+ ;; find the specific case, rename args, and goto the case label
+ (let lp ((lcase (lambda-body
+ (assq-ref fix-labels (lexical-ref-gensym proc)))))
+ (cond
+ ((and (lambda-case? lcase)
+ (not (lambda-case-kw lcase))
+ (not (lambda-case-opt lcase))
+ (not (lambda-case-rest lcase))
+ (= (length args) (length (lambda-case-req lcase))))
+ ;; we have a case that matches the args; rename variables
+ ;; and goto the case label
+ (for-each (lambda (sym)
+ (pmatch (hashq-ref (hashq-ref allocation sym) self)
+ ((#t #f . ,index) ; unboxed
+ (emit-code #f (make-glil-lexical #t #f 'set index)))
+ ((#t #t . ,index) ; boxed
+ (emit-code #f (make-glil-lexical #t #t 'box index)))
+ (,x (error "bad lambda-case arg allocation" x))))
+ (reverse (lambda-case-gensyms lcase)))
+ (emit-branch src 'br (car (hashq-ref allocation lcase))))
+ ((lambda-case? lcase)
+ ;; no match, try next case
+ (lp (lambda-case-alternate lcase)))
+ (else
+ ;; no cases left. we can't really handle this currently.
+ ;; ideally we would push on a new frame, then do a "local
+ ;; call" -- which doesn't require consing up a program
+ ;; object. but for now error, as this sort of case should
+ ;; preclude label allocation.
+ (error "couldn't find matching case for label call" x)))))
+
+ (else
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push proc)
+ (for-each comp-push args)
+ (let ((len (length args)))
+ (case context
+ ((tail) (if (<= len #xff)
+ (emit-code src (make-glil-call 'tail-call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'tail-call/nargs 0)))))
+ ((push) (if (<= len #xff)
+ (emit-code src (make-glil-call 'call len))
+ (begin
+ (comp-push (make-const #f len))
+ (emit-code src (make-glil-call 'call/nargs 0))))
+ (maybe-emit-return))
+ ;; FIXME: mv-call doesn't have a /nargs variant, so it is
+ ;; limited to 255 args. Can work around it with a
+ ;; trampoline and tail-call/nargs, but it's not so nice.
+ ((vals) (emit-code src (make-glil-mv-call len MVRA))
+ (maybe-emit-return))
+ ((drop) (let ((MV (make-label)) (POST (make-label)))
+ (emit-code src (make-glil-mv-call len MV))
+ (emit-code #f (make-glil-call 'drop 1))
+ (emit-branch #f 'br (or RA POST))
+ (emit-label MV)
+ (emit-code #f (make-glil-mv-bind 0 #f))
+ (if RA
+ (emit-branch #f 'br RA)
+ (emit-label POST)))))))))
+
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args))
+ (maybe-emit-return))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
+ ((<conditional> src test consequent alternate)
+ ;; TEST
+ ;; (br-if-not L1)
+ ;; consequent
+ ;; (br L2)
+ ;; L1: alternate
+ ;; L2:
+ (let ((L1 (make-label)) (L2 (make-label)))
+ (record-case test
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-nil L1))
+ ((not ,x)
+ (record-case x
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-null L1))
+ ((nil? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-nil L1))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1))))
+ (else
+ (comp-push test)
+ (emit-branch src 'br-if-not L1)))
+
+ (comp-tail consequent)
+ ;; if there is an RA, comp-tail will cause a jump to it -- just
+ ;; have to clean up here if there is no RA.
+ (if (and (not RA) (not (eq? context 'tail)))
+ (emit-branch #f 'br L2))
+ (emit-label L1)
+ (comp-tail alternate)
+ (if (and (not RA) (not (eq? context 'tail)))
+ (emit-label L2))))
+
+ ((<primitive-ref> src name)
+ (cond
+ ((eq? (module-variable (fluid-ref *comp-module*) name)
+ (module-variable the-root-module name))
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-toplevel 'ref name))))
+ (maybe-emit-return))
+ ((module-variable the-root-module name)
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-module 'ref '(guile) name #f))))
+ (maybe-emit-return))
+ (else
+ (case context
+ ((tail push vals)
+ (emit-code src (make-glil-module
+ 'ref (module-name (fluid-ref *comp-module*)) name #f))))
+ (maybe-emit-return))))
+
+ ((<lexical-ref> src gensym)
+ (case context
+ ((push vals tail)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'ref index)))
+ (,loc
+ (error "bad lexical allocation" x loc)))))
+ (maybe-emit-return))
+
+ ((<lexical-set> src gensym exp)
+ (comp-push exp)
+ (pmatch (hashq-ref (hashq-ref allocation gensym) self)
+ ((,local? ,boxed? . ,index)
+ (emit-code src (make-glil-lexical local? boxed? 'set index)))
+ (,loc
+ (error "bad lexical allocation" x loc)))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<module-ref> src mod name public?)
+ (emit-code src (make-glil-module 'ref mod name public?))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+
+ ((<module-set> src mod name public? exp)
+ (comp-push exp)
+ (emit-code src (make-glil-module 'set mod name public?))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<toplevel-ref> src name)
+ (emit-code src (make-glil-toplevel 'ref name))
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+
+ ((<toplevel-set> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'set name))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<toplevel-define> src name exp)
+ (comp-push exp)
+ (emit-code src (make-glil-toplevel 'define name))
+ (case context
+ ((tail push vals)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ((<lambda>)
+ (let ((free-locs (cdr (hashq-ref allocation x))))
+ (case context
+ ((push vals tail)
+ (emit-code #f (flatten-lambda x #f allocation))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "bad lambda free var allocation" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))))
+ (maybe-emit-return))
+
+ ((<lambda-case> src req opt rest kw inits gensyms alternate body)
+ ;; o/~ feature on top of feature o/~
+ ;; req := (name ...)
+ ;; opt := (name ...) | #f
+ ;; rest := name | #f
+ ;; kw: (allow-other-keys? (keyword name var) ...) | #f
+ ;; gensyms: (sym ...)
+ ;; init: tree-il in context of gensyms
+ ;; gensyms map to named arguments in the following order:
+ ;; required, optional (positional), rest, keyword.
+ (let* ((nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (rest-idx (and rest (+ nreq nopt)))
+ (opt-names (or opt '()))
+ (allow-other-keys? (if kw (car kw) #f))
+ (kw-indices (map (lambda (x)
+ (pmatch x
+ ((,key ,name ,var)
+ (cons key (list-index gensyms var)))
+ (else (error "bad kwarg" x))))
+ (if kw (cdr kw) '())))
+ (nargs (apply max (+ nreq nopt (if rest 1 0))
+ (map 1+ (map cdr kw-indices))))
+ (nlocs (cdr (hashq-ref allocation x)))
+ (alternate-label (and alternate (make-label))))
+ (or (= nargs
+ (length gensyms)
+ (+ nreq (length inits) (if rest 1 0)))
+ (error "lambda-case gensyms don't correspond to args"
+ req opt rest kw inits gensyms nreq nopt kw-indices nargs))
+ ;; the prelude, to check args & reset the stack pointer,
+ ;; allowing room for locals
+ (emit-code
+ src
+ (cond
+ (kw
+ (make-glil-kw-prelude nreq nopt rest-idx kw-indices
+ allow-other-keys? nlocs alternate-label))
+ ((or rest opt)
+ (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
+ (#t
+ (make-glil-std-prelude nreq nlocs alternate-label))))
+ ;; box args if necessary
+ (for-each
+ (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ gensyms)
+ ;; write bindings info
+ (if (not (null? gensyms))
+ (emit-bindings
+ #f
+ (let lp ((kw (if kw (cdr kw) '()))
+ (names (append (reverse opt-names) (reverse req)))
+ (gensyms (list-tail gensyms (+ nreq nopt
+ (if rest 1 0)))))
+ (pmatch kw
+ (()
+ ;; fixme: check that gensyms is empty
+ (reverse (if rest (cons rest names) names)))
+ (((,key ,name ,var) . ,kw)
+ (if (memq var gensyms)
+ (lp kw (cons name names) (delq var gensyms))
+ (lp kw names gensyms)))
+ (,kw (error "bad keywords, yo" kw))))
+ gensyms allocation self emit-code))
+ ;; init optional/kw args
+ (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
+ (cond
+ ((null? inits)) ; done
+ ((and rest-idx (= n rest-idx))
+ (lp inits (1+ n) (cdr gensyms)))
+ (#t
+ (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
+ ((#t ,boxed? . ,n*) (guard (= n* n))
+ (let ((L (make-label)))
+ (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
+ (emit-code #f (make-glil-branch 'br-if L))
+ (comp-push (car inits))
+ (emit-code #f (make-glil-lexical #t boxed? 'set n))
+ (emit-label L)
+ (lp (cdr inits) (1+ n) (cdr gensyms))))
+ (#t (error "bad arg allocation" (car gensyms) inits))))))
+ ;; post-prelude case label for label calls
+ (emit-label (car (hashq-ref allocation x)))
+ (comp-tail body)
+ (if (not (null? gensyms))
+ (emit-code #f (make-glil-unbind)))
+ (if alternate-label
+ (begin
+ (emit-label alternate-label)
+ (flatten-lambda-case alternate allocation self self-label
+ fix-labels emit-code)))))
+
+ ((<let> src names gensyms vals body)
+ (for-each comp-push vals)
+ (emit-bindings src names gensyms allocation self emit-code)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "bad let var allocation" x loc))))
+ (reverse gensyms))
+ (comp-tail body)
+ (clear-stack-slots context gensyms)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<letrec> src in-order? names gensyms vals body)
+ ;; First prepare heap storage slots.
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'empty-box n)))
+ (,loc (error "bad letrec var allocation" x loc))))
+ gensyms)
+ ;; Even though the slots are empty, the bindings are valid.
+ (emit-bindings src names gensyms allocation self emit-code)
+ (cond
+ (in-order?
+ ;; For letrec*, bind values in order.
+ (for-each (lambda (name v val)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (comp-push val)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "bad letrec var allocation" x loc))))
+ names gensyms vals))
+ (else
+ ;; But for letrec, eval all values, then bind.
+ (for-each comp-push vals)
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'set n)))
+ (,loc (error "bad letrec var allocation" x loc))))
+ (reverse gensyms))))
+ (comp-tail body)
+ (clear-stack-slots context gensyms)
+ (emit-code #f (make-glil-unbind)))
+
+ ((<fix> src names gensyms vals body)
+ ;; The ideal here is to just render the lambda bodies inline, and
+ ;; wire the code together with gotos. We can do that if
+ ;; analyze-lexicals has determined that a given var has "label"
+ ;; allocation -- which is the case if it is in `fix-labels'.
+ ;;
+ ;; But even for closures that we can't inline, we can do some
+ ;; tricks to avoid heap-allocation for the binding itself. Since
+ ;; we know the vals are lambdas, we can set them to their local
+ ;; var slots first, then capture their bindings, mutating them in
+ ;; place.
+ (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
+ (for-each
+ (lambda (x v)
+ (cond
+ ((hashq-ref allocation x)
+ ;; allocating a closure
+ (emit-code #f (flatten-lambda x v allocation))
+ (let ((free-locs (cdr (hashq-ref allocation x))))
+ (if (not (null? free-locs))
+ ;; Need to make-closure first, so we have a fresh closure on
+ ;; the heap, but with a temporary free values.
+ (begin
+ (for-each (lambda (loc)
+ (emit-code #f (make-glil-const #f)))
+ free-locs)
+ (emit-code #f (make-glil-call 'make-closure
+ (length free-locs))))))
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "bad fix var allocation" x loc))))
+ (else
+ ;; labels allocation: emit label & body, but jump over it
+ (let ((POST (make-label)))
+ (emit-branch #f 'br POST)
+ (let lp ((lcase (lambda-body x)))
+ (if lcase
+ (record-case lcase
+ ((<lambda-case> src req gensyms body alternate)
+ (emit-label (car (hashq-ref allocation lcase)))
+ ;; FIXME: opt & kw args in the bindings
+ (emit-bindings #f req gensyms allocation self emit-code)
+ (if src
+ (emit-code #f (make-glil-source src)))
+ (comp-fix body (or RA new-RA))
+ (emit-code #f (make-glil-unbind))
+ (lp alternate)))
+ (emit-label POST)))))))
+ vals
+ gensyms)
+ ;; Emit bindings metadata for closures
+ (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
+ (cond ((null? gensyms) (reverse! out))
+ ((assq (car gensyms) fix-labels)
+ (lp out (cdr gensyms) (cdr names)))
+ (else
+ (lp (acons (car gensyms) (car names) out)
+ (cdr gensyms) (cdr names)))))))
+ (emit-bindings src (map cdr binds) (map car binds)
+ allocation self emit-code))
+ ;; Now go back and fix up the bindings for closures.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (if (hashq-ref allocation x)
+ (cdr (hashq-ref allocation x))
+ ;; can hit this latter case for labels allocation
+ '())))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "bad free var allocation" x loc))))
+ free-locs)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "bad fix var allocation" x loc)))))))
+ vals
+ gensyms)
+ (comp-tail body)
+ (if new-RA
+ (emit-label new-RA))
+ (clear-stack-slots context gensyms)
+ (emit-code #f (make-glil-unbind))))
+
+ ((<let-values> src exp body)
+ (record-case body
+ ((<lambda-case> req opt kw rest gensyms body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in let-values" x))
+ (let ((MV (make-label)))
+ (comp-vals exp MV)
+ (emit-code #f (make-glil-const 1))
+ (emit-label MV)
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ gensyms allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc (error "bad let-values var allocation" x loc))))
+ (reverse gensyms))
+ (comp-tail body)
+ (clear-stack-slots context gensyms)
+ (emit-code #f (make-glil-unbind))))))
+
+ ;; much trickier than i thought this would be, at first, due to the need
+ ;; to have body's return value(s) on the stack while the unwinder runs,
+ ;; then proceed with returning or dropping or what-have-you, interacting
+ ;; with RA and MVRA. What have you, I say.
+ ((<dynwind> src winder pre body post unwinder)
+ (define (thunk? x)
+ (and (lambda? x)
+ (null? (lambda-case-gensyms (lambda-body x)))))
+ (define (make-wrong-type-arg x)
+ (make-primcall src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list x))
+ (make-primcall #f 'list (list x)))))
+ (define (emit-thunk-check x)
+ (comp-drop (make-conditional
+ src
+ (make-primcall src 'thunk? (list x))
+ (make-void #f)
+ (make-wrong-type-arg x))))
+
+ ;; We know at this point that `winder' and `unwinder' are
+ ;; constant expressions and can be duplicated.
+ (if (not (thunk? winder))
+ (emit-thunk-check winder))
+ (comp-push winder)
+ (if (not (thunk? unwinder))
+ (emit-thunk-check unwinder))
+ (comp-push unwinder)
+ (comp-drop pre)
+ (emit-code #f (make-glil-call 'wind 2))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; ...and return the val
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and return the values.
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value
+ (comp-push body)
+ ;; and unwind, leaving the val on the stack
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind...
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and goto the MVRA.
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (comp-drop post)
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynlet> src fluids vals body)
+ (for-each comp-push fluids)
+ (for-each comp-push vals)
+ (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
+
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ ;; NB: in tail case, it is possible to preserve asymptotic tail
+ ;; recursion, via merging unwind-fluids structures -- but we'd need
+ ;; to compile in the body twice (once in tail context, assuming the
+ ;; caller unwinds, and once with this trampoline thing, unwinding
+ ;; ourselves).
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and return values
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0)))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+
+ (emit-label MV)
+ ;; multiple values: unwind and goto MVRA
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values. then unwind...
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind-fluids 0))
+ ;; and fall through, or goto RA if there is one.
+ (if RA
+ (emit-branch #f 'br RA)))))
+
+ ((<dynref> src fluid)
+ (case context
+ ((drop)
+ (comp-drop fluid))
+ ((push vals tail)
+ (comp-push fluid)
+ (emit-code #f (make-glil-call 'fluid-ref 1))))
+ (maybe-emit-return))
+
+ ((<dynset> src fluid exp)
+ (comp-push fluid)
+ (comp-push exp)
+ (emit-code #f (make-glil-call 'fluid-set 2))
+ (case context
+ ((push vals tail)
+ (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ ;; What's the deal here? The deal is that we are compiling the start of a
+ ;; delimited continuation. We try to avoid heap allocation in the normal
+ ;; case; so the body is an expression, not a thunk, and we try to render
+ ;; the handler inline. Also we did some analysis, in analyze.scm, so that
+ ;; if the continuation isn't referenced, we don't reify it. This makes it
+ ;; possible to implement catch and throw with delimited continuations,
+ ;; without any overhead.
+ ((<prompt> src tag body handler)
+ (let ((H (make-label))
+ (POST (make-label))
+ (escape-only? (hashq-ref allocation x)))
+ ;; First, set up the prompt.
+ (comp-push tag)
+ (emit-code src (make-glil-prompt H escape-only?))
+
+ ;; Then we compile the body, with its normal return path, unwinding
+ ;; before proceeding.
+ (case context
+ ((tail)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: unwind and return
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return 1))
+ ;; multiple values: unwind and return
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-code #f (make-glil-call 'return/nvalues 1))))
+
+ ((push)
+ ;; we only want one value. so ask for one value, unwind, and jump to
+ ;; post
+ (comp-push body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br (or RA POST)))
+
+ ((vals)
+ (let ((MV (make-label)))
+ (comp-vals body MV)
+ ;; one value: push 1 and fall through to MV case
+ (emit-code #f (make-glil-const 1))
+ ;; multiple values: unwind and goto MVRA
+ (emit-label MV)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br MVRA)))
+
+ ((drop)
+ ;; compile body, discarding values, then unwind & fall through.
+ (comp-drop body)
+ (emit-code #f (make-glil-call 'unwind 0))
+ (emit-branch #f 'br (or RA POST))))
+
+ (emit-label H)
+ ;; Now the handler. The stack is now made up of the continuation, and
+ ;; then the args to the continuation (pushed separately), and then the
+ ;; number of args, including the continuation.
+ (record-case handler
+ ((<lambda-case> req opt kw rest gensyms body alternate)
+ (if (or opt kw alternate)
+ (error "unexpected lambda-case in prompt" x))
+ (emit-code src (make-glil-mv-bind
+ (vars->bind-list
+ (append req (if rest (list rest) '()))
+ gensyms allocation self)
+ (and rest #t)))
+ (for-each (lambda (v)
+ (pmatch (hashq-ref (hashq-ref allocation v) self)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ ((#t #t . ,n)
+ (emit-code src (make-glil-lexical #t #t 'box n)))
+ (,loc
+ (error "bad prompt handler arg allocation" x loc))))
+ (reverse gensyms))
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind))))
+
+ (if (and (not RA)
+ (or (eq? context 'push) (eq? context 'drop)))
+ (emit-label POST))))
+
+ ((<abort> src tag args tail)
+ (comp-push tag)
+ (for-each comp-push args)
+ (comp-push tail)
+ (emit-code src (make-glil-call 'abort (length args)))
+ ;; so, the abort can actually return. if it does, the values will be on
+ ;; the stack, then the MV marker, just as in an MV context.
+ (case context
+ ((tail)
+ ;; Return values.
+ (emit-code #f (make-glil-call 'return/nvalues 1)))
+ ((drop)
+ ;; Drop all values and goto RA, or otherwise fall through.
+ (emit-code #f (make-glil-mv-bind 0 #f))
+ (if RA (emit-branch #f 'br RA)))
+ ((push)
+ ;; Truncate to one value.
+ (emit-code #f (make-glil-mv-bind 1 #f)))
+ ((vals)
+ ;; Go to MVRA.
+ (emit-branch #f 'br MVRA)))))))
HCoop / bpt / guile.git / blobdiff