mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-06 23:50:18 +02:00
Code Activity
guile/module/language/tree-il/compile-glil.scm
Andy Wingo 60ed31d28b allow primcall ops to push 0 values 
* libguile/objcodes.c (OBJCODE_COOKIE): Bump the objcode cookie. We'll
  be doing this on incompatible changes until 2.0.

* libguile/vm-i-scheme.c (set_car, set_cdr, slot_set): These
  instructions don't have natural return values -- so declare them that
  way, that they push 0 values.

* module/language/tree-il/compile-glil.scm (flatten): When compiling
  primitive calls, check `(instruction-pushes op)' to see how many
  values that instruction will push, and do something appropriate,
  instead of just assuming that all primcall ops push 1 value.
2009-06-24 15:14:00 +02:00

517 lines
19 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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 (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 -> (local . index) | (heap level . index)
;; lambda -> (nlocs . nexts)
(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 -1 allocation)
(and e (cons (car e) (cddr e)))
e)))))
(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)))
(define (make-label) (gensym ":L"))
(define (vars->bind-list ids vars allocation)
(map (lambda (id v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack) (list id 'local (cdr loc)))
((heap) (list id 'external (cddr loc)))
(else (error "badness" id v loc)))))
ids
vars))
(define (emit-bindings src ids vars allocation emit-code)
(if (pair? vars)
(emit-code src (make-glil-bind
(vars->bind-list ids vars allocation)))))
(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 level 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)))
(nexts (cdr (hashq-ref allocation x))))
(make-glil-program
nargs nrest nlocs nexts (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; write bindings and source debugging info
(emit-bindings #f ids vars allocation emit-code)
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
;; copy args to the heap if necessary
(let lp ((in vars) (n 0))
(if (not (null? in))
(let ((loc (hashq-ref allocation (car in))))
(case (car loc)
((heap)
(emit-code #f (make-glil-local 'ref n))
(emit-code #f (make-glil-external 'set 0 (cddr loc)))))
(lp (cdr in) (1+ n)))))
;; and here, here, dear reader: we compile.
(flatten (lambda-body x) (1+ level) allocation emit-code)))))))
(define (flatten x level allocation 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)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'ref (cdr loc))))
((heap)
(emit-code src (make-glil-external
'ref (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc)))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))))
((<lexical-set> src name gensym exp)
(comp-push exp)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external
'set (- level (cadr loc)) (cddr loc))))
(else (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>)
(case context
((push vals)
(emit-code #f (flatten-lambda x level allocation)))
((tail)
(emit-code #f (flatten-lambda x level allocation))
(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 emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals body)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (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)
rest?))
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))))))
View git blame Copy permalink