module/language/glil.scm

   1 ;;; Guile Low Intermediate Language
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library 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 GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language glil)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module ((srfi srfi-1) #:select (fold))
  25   #:export
  26   (<glil-program> make-glil-program glil-program?
  27    glil-program-nargs glil-program-nrest glil-program-nlocs
  28    glil-program-meta glil-program-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-props
  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-lexical> make-glil-lexical glil-lexical?
  47    glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
  48
  49    <glil-toplevel> make-glil-toplevel glil-toplevel?
  50    glil-toplevel-op glil-toplevel-name
  51
  52    <glil-module> make-glil-module glil-module?
  53    glil-module-op glil-module-mod glil-module-name glil-module-public?
  54
  55    <glil-label> make-glil-label glil-label?
  56    glil-label-label
  57
  58    <glil-branch> make-glil-branch glil-branch?
  59    glil-branch-inst glil-branch-label
  60
  61    <glil-call> make-glil-call glil-call?
  62    glil-call-inst glil-call-nargs
  63
  64    <glil-mv-call> make-glil-mv-call glil-mv-call?
  65    glil-mv-call-nargs glil-mv-call-ra
  66
  67    parse-glil unparse-glil))
  68
  69 (define (print-glil x port)
  70   (format port "#<glil ~s>" (unparse-glil x)))
  71
  72 (define-type (<glil> #:printer print-glil)
  73   ;; Meta operations
  74   (<glil-program> nargs nrest nlocs meta body)
  75   (<glil-bind> vars)
  76   (<glil-mv-bind> vars rest)
  77   (<glil-unbind>)
  78   (<glil-source> props)
  79   ;; Objects
  80   (<glil-void>)
  81   (<glil-const> obj)
  82   ;; Variables
  83   (<glil-lexical> local? boxed? op index)
  84   (<glil-toplevel> op name)
  85   (<glil-module> op mod name public?)
  86   ;; Controls
  87   (<glil-label> label)
  88   (<glil-branch> inst label)
  89   (<glil-call> inst nargs)
  90   (<glil-mv-call> nargs ra))
  91
  92 \f
  93
  94 (define (parse-glil x)
  95   (pmatch x
  96     ((program ,nargs ,nrest ,nlocs ,meta . ,body)
  97      (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
  98     ((bind . ,vars) (make-glil-bind vars))
  99     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
 100     ((unbind) (make-glil-unbind))
 101     ((source ,props) (make-glil-source props))
 102     ((void) (make-glil-void))
 103     ((const ,obj) (make-glil-const obj))
 104     ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
 105     ((toplevel ,op ,name) (make-glil-toplevel op name))
 106     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
 107     ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
 108     ((label ,label) (make-label label))
 109     ((branch ,inst ,label) (make-glil-branch inst label))
 110     ((call ,inst ,nargs) (make-glil-call inst nargs))
 111     ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
 112     (else (error "invalid glil" x))))
 113
 114 (define (unparse-glil glil)
 115   (record-case glil
 116     ;; meta
 117     ((<glil-program> nargs nrest nlocs meta body)
 118      `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
 119     ((<glil-bind> vars) `(bind ,@vars))
 120     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
 121     ((<glil-unbind>) `(unbind))
 122     ((<glil-source> props) `(source ,props))
 123     ;; constants
 124     ((<glil-void>) `(void))
 125     ((<glil-const> obj) `(const ,obj))
 126     ;; variables
 127     ((<glil-lexical> local? boxed? op index)
 128      `(lexical ,local? ,boxed? ,op ,index))
 129     ((<glil-toplevel> op name)
 130      `(toplevel ,op ,name))
 131     ((<glil-module> op mod name public?)
 132      `(module ,(if public? 'public 'private) ,op ,mod ,name))
 133     ;; controls
 134     ((<glil-label> label) `(label ,label))
 135     ((<glil-branch> inst label) `(branch ,inst ,label))
 136     ((<glil-call> inst nargs) `(call ,inst ,nargs))
 137     ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))))