mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 20:30:28 +02:00
486013d67c
* libguile/Makefile.am: * libguile/vm-builtins.h: New header, declaring stubs needed by the compiler like values, apply, and abort-to-prompt. * libguile/vm.c: Adapt the apply and values stubs to conform to a standard interface. Add an abort-to-prompt stub. Add call/cc and call-with-values stubs. (scm_vm_builtin_ref): New helper, for the builtin-ref opcode. (scm_vm_builtin_name_to_index) (scm_vm_builtin_index_to_name): New helpers, for the compiler and disassembler, respectively. (scm_init_vm_builtins, scm_bootstrap_vm): Allow the compiler helpers to be loaded later into a module. * module/language/rtl.scm: Export builtin-index->name and builtin-name->index. * libguile/vm-engine.c (RETURN_VALUE_LIST): Update to use new names of "apply" and "values". (tail-call/shuffle): New opcode. (abort): Update to be a tail VM op, and reorder and renumber other ops. (builtin-ref): New opcode. * libguile/continuations.h: * libguile/continuations.c (scm_i_call_with_current_continuation): Move this to vm.[ch], implemented as a builtin. * module/language/tree-il/compile-cps.scm (convert): Convert to 'abort-to-prompt calls, possibly with 'apply, effectively undoing the tree-il transformation. * module/language/cps/reify-primitives.scm (builtin-ref): New helper. (reify-primitives): Convert builtin primitives to builtin-ref. * module/language/cps/dfg.scm (constant-needs-allocation?): * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add support for compiling builtin-ref. * module/system/vm/disassembler.scm (code-annotation): Add annotation for builtin-ref.
97 lines
2.9 KiB
Scheme
97 lines
2.9 KiB
Scheme
;;; Register Transfer Language (RTL)
|
|
|
|
;; Copyright (C) 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 rtl)
|
|
#:use-module (ice-9 match)
|
|
#:use-module ((srfi srfi-1) #:select (fold))
|
|
#:use-module (system vm instruction)
|
|
#:re-export (rtl-instruction-list)
|
|
#:export (rtl-instruction-arity
|
|
builtin-name->index
|
|
builtin-index->name))
|
|
|
|
(load-extension (string-append "libguile-" (effective-version))
|
|
"scm_init_vm_builtins")
|
|
|
|
(define (compute-rtl-instruction-arity name args)
|
|
(define (first-word-arity word)
|
|
(case word
|
|
((U8_X24) 0)
|
|
((U8_U24) 1)
|
|
((U8_L24) 1)
|
|
((U8_U8_I16) 2)
|
|
((U8_U12_U12) 2)
|
|
((U8_U8_U8_U8) 3)))
|
|
(define (tail-word-arity word)
|
|
(case word
|
|
((U8_U24) 2)
|
|
((U8_L24) 2)
|
|
((U8_U8_I16) 3)
|
|
((U8_U12_U12) 3)
|
|
((U8_U8_U8_U8) 4)
|
|
((U32) 1)
|
|
((I32) 1)
|
|
((A32) 1)
|
|
((B32) 0)
|
|
((N32) 1)
|
|
((S32) 1)
|
|
((L32) 1)
|
|
((LO32) 1)
|
|
((X8_U24) 1)
|
|
((X8_U12_U12) 2)
|
|
((X8_L24) 1)
|
|
((B1_X7_L24) 2)
|
|
((B1_U7_L24) 3)
|
|
((B1_X31) 1)
|
|
((B1_X7_U24) 2)))
|
|
(match args
|
|
((arg0 . args)
|
|
(fold (lambda (arg arity)
|
|
(+ (tail-word-arity arg) arity))
|
|
(first-word-arity arg0)
|
|
args))))
|
|
|
|
(define *macro-instruction-arities*
|
|
'((cache-current-module! . (0 . 2))
|
|
(cached-toplevel-box . (1 . 3))
|
|
(cached-module-box . (1 . 4))))
|
|
|
|
(define (compute-rtl-instruction-arities)
|
|
(let ((table (make-hash-table)))
|
|
(for-each
|
|
(match-lambda
|
|
;; Put special cases here.
|
|
((name op '! . args)
|
|
(hashq-set! table name
|
|
(cons 0 (compute-rtl-instruction-arity name args))))
|
|
((name op '<- . args)
|
|
(hashq-set! table name
|
|
(cons 1 (1- (compute-rtl-instruction-arity name args))))))
|
|
(rtl-instruction-list))
|
|
(for-each (match-lambda
|
|
((name . arity)
|
|
(hashq-set! table name arity)))
|
|
*macro-instruction-arities*)
|
|
table))
|
|
|
|
(define *rtl-instruction-arities* (delay (compute-rtl-instruction-arities)))
|
|
|
|
(define (rtl-instruction-arity name)
|
|
(hashq-ref (force *rtl-instruction-arities*) name))
|