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   #:export
  26   (<glil-asm> make-glil-asm glil-asm?
  27    glil-asm-nargs glil-asm-nrest glil-asm-nlocs glil-asm-nexts
  28    glil-asm-meta glil-asm-body
  29
  30    <glil-bind> make-glil-bind glil-bind?
  31    glil-bind-vars
  32
  33    <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
  34    glil-mv-bind-vars glil-mv-bind-rest
  35
  36    <glil-unbind> make-glil-unbind glil-unbind?
  37
  38    <glil-source> make-glil-source glil-source?
  39    glil-source-loc
  40
  41    <glil-void> make-glil-void glil-void?
  42
  43    <glil-const> make-glil-const glil-const?
  44    glil-const-obj
  45
  46    <glil-argument> make-glil-argument glil-argument?
  47    glil-argument-op glil-argument-index
  48
  49    <glil-local> make-glil-local glil-local?
  50    glil-local-op glil-local-index
  51
  52    <glil-external> make-glil-external glil-external?
  53    glil-external-op glil-external-depth glil-external-index
  54
  55    <glil-toplevel> make-glil-toplevel glil-toplevel?
  56    glil-toplevel-op glil-toplevel-name
  57
  58    <glil-module> make-glil-module glil-module?
  59    glil-module-op glil-module-mod glil-module-name glil-module-public?
  60
  61    <glil-label> make-glil-label glil-label?
  62    glil-label-label
  63
  64    <glil-branch> make-glil-branch glil-branch?
  65    glil-branch-inst glil-branch-label
  66
  67    <glil-call> make-glil-call glil-call?
  68    glil-call-inst glil-call-nargs
  69
  70    <glil-mv-call> make-glil-mv-call glil-mv-call?
  71    glil-mv-call-nargs glil-mv-call-ra
  72
  73    parse-glil unparse-glil))
  74
  75 (define (print-glil x port)
  76   (format port "#<glil ~s>" (unparse-glil x)))
  77
  78 (define-type (<glil> #:printer print-glil)
  79   ;; Meta operations
  80   (<glil-asm> nargs nrest nlocs nexts meta body)
  81   (<glil-bind> vars)
  82   (<glil-mv-bind> vars rest)
  83   (<glil-unbind>)
  84   (<glil-source> loc)
  85   ;; Objects
  86   (<glil-void>)
  87   (<glil-const> obj)
  88   ;; Variables
  89   (<glil-argument> op index)
  90   (<glil-local> op index)
  91   (<glil-external> op depth index)
  92   (<glil-toplevel> op name)
  93   (<glil-module> op mod name public?)
  94   ;; Controls
  95   (<glil-label> label)
  96   (<glil-branch> inst label)
  97   (<glil-call> inst nargs)
  98   (<glil-mv-call> nargs ra))
  99
 100 \f
 101 (define (parse-glil x)
 102   (pmatch x
 103     ((asm ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
 104      (make-glil-asm nargs nrest nlocs nexts meta (map parse-glil body)))
 105     ((bind . ,vars) (make-glil-bind vars))
 106     ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
 107     ((unbind) (make-glil-unbind))
 108     ((source ,loc) (make-glil-source loc))
 109     ((void) (make-glil-void))
 110     ((const ,obj) (make-glil-const obj))
 111     ((argument ,op ,index) (make-glil-argument op index))
 112     ((local ,op ,index) (make-glil-local op index))
 113     ((external ,op ,depth ,index) (make-glil-external op depth index))
 114     ((toplevel ,op ,name) (make-glil-toplevel op name))
 115     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
 116     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
 117     ((label ,label) (make-label ,label))
 118     ((branch ,inst ,label) (make-glil-branch inst label))
 119     ((call ,inst ,nargs) (make-glil-call inst nargs))
 120     ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
 121     (else (error "invalid glil" x))))
 122
 123 (define (unparse-glil glil)
 124   (record-case glil
 125     ;; meta
 126     ((<glil-asm> nargs nrest nlocs nexts meta body)
 127      `(asm ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
 128     ((<glil-bind> vars) `(bind ,@vars))
 129     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
 130     ((<glil-unbind>) `(unbind))
 131     ((<glil-source> loc) `(source ,loc))
 132     ;; constants
 133     ((<glil-void>) `(void))
 134     ((<glil-const> obj) `(const ,obj))
 135     ;; variables
 136     ((<glil-argument> op index)
 137      `(argument ,op ,index))
 138     ((<glil-local> op index)
 139      `(local ,op ,index))
 140     ((<glil-external> op depth index)
 141      `(external ,op ,depth ,index))
 142     ((<glil-toplevel> op name)
 143      `(toplevel ,op ,name))
 144     ((<glil-module> op mod name public?)
 145      `(module ,(if public? 'public 'private) ,op ,mod ,name))
 146     ;; controls
 147     ((<glil-label> label) (label ,label))
 148     ((<glil-branch> inst label) `(branch ,inst ,label))
 149     ((<glil-call> inst nargs) `(call ,inst ,nargs))
 150     ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))