module/language/glil.scm

   1 ;;; Guile Low Intermediate Language
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language glil)
  23   #:use-module (system base syntax)
  24   #:use-module (system base pmatch)
  25   #:use-module ((srfi srfi-1) #:select (fold))
  26   #:export
  27   (<glil-program> make-glil-program glil-program?
  28    glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
  29    glil-program-meta glil-program-body glil-program-closure-level
  30
  31    <glil-bind> make-glil-bind glil-bind?
  32    glil-bind-vars
  33
  34    <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
  35    glil-mv-bind-vars glil-mv-bind-rest
  36
  37    <glil-unbind> make-glil-unbind glil-unbind?
  38
  39    <glil-source> make-glil-source glil-source?
  40    glil-source-props
  41
  42    <glil-void> make-glil-void glil-void?
  43
  44    <glil-const> make-glil-const glil-const?
  45    glil-const-obj
  46
  47    <glil-argument> make-glil-argument glil-argument?
  48    glil-argument-op glil-argument-index
  49
  50    <glil-local> make-glil-local glil-local?
  51    glil-local-op glil-local-index
  52
  53    <glil-external> make-glil-external glil-external?
  54    glil-external-op glil-external-depth glil-external-index
  55
  56    <glil-toplevel> make-glil-toplevel glil-toplevel?
  57    glil-toplevel-op glil-toplevel-name
  58
  59    <glil-module> make-glil-module glil-module?
  60    glil-module-op glil-module-mod glil-module-name glil-module-public?
  61
  62    <glil-label> make-glil-label glil-label?
  63    glil-label-label
  64
  65    <glil-branch> make-glil-branch glil-branch?
  66    glil-branch-inst glil-branch-label
  67
  68    <glil-call> make-glil-call glil-call?
  69    glil-call-inst glil-call-nargs
  70
  71    <glil-mv-call> make-glil-mv-call glil-mv-call?
  72    glil-mv-call-nargs glil-mv-call-ra
  73
  74    parse-glil unparse-glil))
  75
  76 (define (print-glil x port)
  77   (format port "#<glil ~s>" (unparse-glil x)))
  78
  79 (define-type (<glil> #:printer print-glil)
  80   ;; Meta operations
  81   (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
  82   (<glil-bind> vars)
  83   (<glil-mv-bind> vars rest)
  84   (<glil-unbind>)
  85   (<glil-source> props)
  86   ;; Objects
  87   (<glil-void>)
  88   (<glil-const> obj)
  89   ;; Variables
  90   (<glil-argument> op index)
  91   (<glil-local> op index)
  92   (<glil-external> op depth index)
  93   (<glil-toplevel> op name)
  94   (<glil-module> op mod name public?)
  95   ;; Controls
  96   (<glil-label> label)
  97   (<glil-branch> inst label)
  98   (<glil-call> inst nargs)
  99   (<glil-mv-call> nargs ra))
 100
 101 (define (compute-closure-level body)
 102   (fold (lambda (x ret)
 103           (record-case x
 104             ((<glil-program> closure-level) (max ret closure-level))
 105             ((<glil-external> depth) (max ret depth))
 106             (else ret)))
 107         0 body))
 108
 109 (define %make-glil-program make-glil-program)
 110 (define (make-glil-program . args)
 111   (let ((prog (apply %make-glil-program args)))
 112     (if (not (glil-program-closure-level prog))
 113         (set! (glil-program-closure-level prog)
 114               (compute-closure-level (glil-program-body prog))))
 115     prog))
 116
 117 \f
 118 (define (parse-glil x)
 119   (pmatch x
 120     ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
 121      (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
 122     ((bind . ,vars) (make-glil-bind vars))
 123     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
 124     ((unbind) (make-glil-unbind))
 125     ((source ,props) (make-glil-source props))
 126     ((void) (make-glil-void))
 127     ((const ,obj) (make-glil-const obj))
 128     ((argument ,op ,index) (make-glil-argument op index))
 129     ((local ,op ,index) (make-glil-local op index))
 130     ((external ,op ,depth ,index) (make-glil-external op depth index))
 131     ((toplevel ,op ,name) (make-glil-toplevel op name))
 132     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
 133     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
 134     ((label ,label) (make-label ,label))
 135     ((branch ,inst ,label) (make-glil-branch inst label))
 136     ((call ,inst ,nargs) (make-glil-call inst nargs))
 137     ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
 138     (else (error "invalid glil" x))))
 139
 140 (define (unparse-glil glil)
 141   (record-case glil
 142     ;; meta
 143     ((<glil-program> nargs nrest nlocs nexts meta body)
 144      `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
 145     ((<glil-bind> vars) `(bind ,@vars))
 146     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
 147     ((<glil-unbind>) `(unbind))
 148     ((<glil-source> props) `(source ,props))
 149     ;; constants
 150     ((<glil-void>) `(void))
 151     ((<glil-const> obj) `(const ,obj))
 152     ;; variables
 153     ((<glil-argument> op index)
 154      `(argument ,op ,index))
 155     ((<glil-local> op index)
 156      `(local ,op ,index))
 157     ((<glil-external> op depth index)
 158      `(external ,op ,depth ,index))
 159     ((<glil-toplevel> op name)
 160      `(toplevel ,op ,name))
 161     ((<glil-module> op mod name public?)
 162      `(module ,(if public? 'public 'private) ,op ,mod ,name))
 163     ;; controls
 164     ((<glil-label> label) `(label ,label))
 165     ((<glil-branch> inst label) `(branch ,inst ,label))
 166     ((<glil-call> inst nargs) `(call ,inst ,nargs))
 167     ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))