mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
9cc649b880
Fixes the mutually-recursive toplevel definitions case. This could be fixed by rewriting bodies as letrecs, as r6 does, but that's not really repl-compatible. * module/system/il/ghil.scm (ghil-lookup): Ok, if we can't locate a variable, mark it as unresolved. * module/system/il/compile.scm (make-glil-var): Compile unresolved variables as <glil-late-bound> objects. * module/system/il/glil.scm: Add <glil-late-bound> definition. * module/system/vm/assemble.scm (codegen): And, finally, when we see a <vlate-bound> object, allocate a slot for it in the object vector, setting it to a symbol. Add a new pair of instructions to resolve that symbol to a variable at the last minute. * src/vm_loader.c (load-number): Bugfix: the radix argument should be SCM_UNDEFINED in order to default to 10. (late-bind): Add an unresolved symbol to the object vector. Could be replaced with load-symbol I guess. * src/vm_system.c (late-variable-ref, late-variable-set): New instructions to do late symbol binding. * testsuite/Makefile.am (vm_test_files): * testsuite/t-mutual-toplevel-defines.scm: New test, failing for some reason involving the core even? and odd? definitions.
211 lines
6 KiB
Scheme
211 lines
6 KiB
Scheme
;;; Guile Low Intermediate Language
|
||
|
||
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||
;; Boston, MA 02111-1307, USA.
|
||
|
||
;;; Code:
|
||
|
||
(define-module (system il glil)
|
||
:use-syntax (system base syntax)
|
||
:export
|
||
(pprint-glil
|
||
<glil-vars> make-glil-vars
|
||
glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
|
||
|
||
<glil-asm> make-glil-asm glil-asm?
|
||
glil-asm-vars glil-asm-body
|
||
|
||
<glil-bind> make-glil-bind glil-bind?
|
||
glil-bind-vars
|
||
|
||
<glil-unbind> make-glil-unbind glil-unbind?
|
||
|
||
<glil-source> make-glil-source glil-source?
|
||
glil-source-loc
|
||
|
||
<glil-void> make-glil-void glil-void?
|
||
|
||
<glil-const> make-glil-const glil-const?
|
||
glil-const-obj
|
||
|
||
<glil-argument> make-glil-argument glil-argument?
|
||
glil-argument-op glil-argument-index
|
||
|
||
<glil-local> make-glil-local glil-local?
|
||
glil-local-op glil-local-index
|
||
|
||
<glil-external> make-glil-external glil-external?
|
||
glil-external-op glil-external-depth glil-external-index
|
||
|
||
<glil-module> make-glil-module glil-module?
|
||
glil-module-op glil-module-module glil-module-index
|
||
|
||
<glil-late-bound> make-glil-late-bound glil-late-bound?
|
||
glil-late-bound-op glil-late-bound-name
|
||
|
||
<glil-label> make-glil-label glil-label?
|
||
glil-label-label
|
||
|
||
<glil-branch> make-glil-branch glil-branch?
|
||
glil-branch-int glil-branch-label
|
||
|
||
<glil-call> make-glil-call glil-call?
|
||
glil-call-int glil-call-nargs))
|
||
|
||
(define-record (<glil-vars> nargs nrest nlocs nexts))
|
||
|
||
(define-type <glil>
|
||
(|
|
||
;; Meta operations
|
||
(<glil-asm> vars body)
|
||
(<glil-bind> vars)
|
||
(<glil-unbind>)
|
||
(<glil-source> loc)
|
||
;; Objects
|
||
(<glil-void>)
|
||
(<glil-const> obj)
|
||
;; Variables
|
||
(<glil-argument> op index)
|
||
(<glil-local> op index)
|
||
(<glil-external> op depth index)
|
||
(<glil-module> op module name)
|
||
(<glil-late-bound> op name)
|
||
;; Controls
|
||
(<glil-label> label)
|
||
(<glil-branch> inst label)
|
||
(<glil-call> inst nargs)))
|
||
|
||
|
||
;;;
|
||
;;; Parser
|
||
;;;
|
||
|
||
;;; (define (parse-glil x)
|
||
;;; (match x
|
||
;;; (('@asm args . body)
|
||
;;; (let* ((env (make-new-env e))
|
||
;;; (args (parse-args args env)))
|
||
;;; (make-asm env args (map-parse body env))))
|
||
;;; (else
|
||
;;; (error "Invalid assembly code:" x))))
|
||
;;;
|
||
;;; (define (parse-args x e)
|
||
;;; (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
|
||
;;; ((list? x) (make-args (map make-local-var x) #f))
|
||
;;; (else (let loop ((l x) (v '()))
|
||
;;; (if (pair? l)
|
||
;;; (loop (cdr l) (cons (car l) v))
|
||
;;; (make-args (map make-local-var
|
||
;;; (reverse! (cons l v)))
|
||
;;; #t)))))))
|
||
;;; (for-each (lambda (v) (env-add! e v)) (args-vars args))
|
||
;;; args))
|
||
;;;
|
||
;;; (define (map-parse x e)
|
||
;;; (map (lambda (x) (parse x e)) x))
|
||
;;;
|
||
;;; (define (parse x e)
|
||
;;; (match x
|
||
;;; ;; (@asm ARGS BODY...)
|
||
;;; (('@asm args . body)
|
||
;;; (parse-asm x e))
|
||
;;; ;; (@bind VARS BODY...)
|
||
;;; ;; (@block VARS BODY...)
|
||
;;; (((or '@bind '@block) vars . body)
|
||
;;; (let* ((offset (env-nvars e))
|
||
;;; (vars (args-vars (parse-args vars e)))
|
||
;;; (block (make-block (car x) offset vars (map-parse body e))))
|
||
;;; (for-each (lambda (v) (env-remove! e)) vars)
|
||
;;; block))
|
||
;;; ;; (void)
|
||
;;; (('void)
|
||
;;; (make-void))
|
||
;;; ;; (const OBJ)
|
||
;;; (('const obj)
|
||
;;; (make-const obj))
|
||
;;; ;; (ref NAME)
|
||
;;; ;; (set NAME)
|
||
;;; (((or 'ref 'set) name)
|
||
;;; (make-access (car x) (env-ref e name)))
|
||
;;; ;; (label LABEL)
|
||
;;; (('label label)
|
||
;;; (make-label label))
|
||
;;; ;; (br-if LABEL)
|
||
;;; ;; (jump LABEL)
|
||
;;; (((or 'br-if 'jump) label)
|
||
;;; (make-instl (car x) label))
|
||
;;; ;; (call NARGS)
|
||
;;; ;; (tail-call NARGS)
|
||
;;; (((or 'call 'tail-call) n)
|
||
;;; (make-instn (car x) n))
|
||
;;; ;; (INST)
|
||
;;; ((inst)
|
||
;;; (if (instruction? inst)
|
||
;;; (make-inst inst)
|
||
;;; (error "Unknown instruction:" inst)))))
|
||
|
||
|
||
;;;
|
||
;;; Unparser
|
||
;;;
|
||
|
||
(define (unparse glil)
|
||
(record-case glil
|
||
;; meta
|
||
((<glil-asm> vars body)
|
||
`(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
|
||
,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
|
||
,@(map unparse body)))
|
||
((<glil-bind> vars) `(@bind ,@vars))
|
||
((<glil-unbind>) `(@unbind))
|
||
((<glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
|
||
;; constants
|
||
((<glil-void>) `(void))
|
||
((<glil-const> obj) `(const ,obj))
|
||
;; variables
|
||
((<glil-argument> op index)
|
||
`(,(symbol-append 'argument- op) ,index))
|
||
((<glil-local> op index)
|
||
`(,(symbol-append 'local- op) ,index))
|
||
((<glil-external> op depth index)
|
||
`(,(symbol-append 'external- op) ,depth ,index))
|
||
((<glil-module> op module name)
|
||
`(,(symbol-append 'module- op) ,module ,name))
|
||
;; controls
|
||
((<glil-label> label) label)
|
||
((<glil-branch> inst label) `(,inst ,label))
|
||
((<glil-call> inst nargs) `(,inst ,nargs))))
|
||
|
||
|
||
;;;
|
||
;;; Printer
|
||
;;;
|
||
|
||
(define (pprint-glil glil . port)
|
||
(let ((port (if (pair? port) (car port) (current-output-port))))
|
||
(let print ((code (unparse glil)) (column 0))
|
||
(display (make-string column #\space) port)
|
||
(cond ((and (pair? code) (eq? (car code) '@asm))
|
||
(format port "(@asm ~A\n" (cadr code))
|
||
(let ((col (+ column 2)))
|
||
(let loop ((l (cddr code)))
|
||
(print (car l) col)
|
||
(if (null? (cdr l))
|
||
(display ")" port)
|
||
(begin (newline port) (loop (cdr l)))))))
|
||
(else (write code port))))
|
||
(newline port)))
|