module/system/il/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 (system il glil)
  23   :use-syntax (system base syntax)
  24   :export
  25   (pprint-glil
  26    <glil-vars> make-glil-vars
  27    glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
  28
  29    <glil-asm> make-glil-asm glil-asm?
  30    glil-asm-vars glil-asm-body
  31
  32    <glil-bind> make-glil-bind glil-bind?
  33    glil-bind-vars
  34
  35    <glil-unbind> make-glil-unbind glil-unbind?
  36
  37    <glil-source> make-glil-source glil-source?
  38    glil-source-loc
  39
  40    <glil-void> make-glil-void glil-void?
  41
  42    <glil-const> make-glil-const glil-const?
  43    glil-const-obj
  44
  45    <glil-argument> make-glil-argument glil-argument?
  46    glil-argument-op glil-argument-index
  47
  48    <glil-local> make-glil-local glil-local?
  49    glil-local-op glil-local-index
  50
  51    <glil-external> make-glil-external glil-external?
  52    glil-external-op glil-external-depth glil-external-index
  53
  54    <glil-module> make-glil-module glil-module?
  55    glil-module-op glil-module-module glil-module-index
  56
  57    <glil-label> make-glil-label glil-label?
  58    glil-label-label
  59
  60    <glil-branch> make-glil-branch glil-branch?
  61    glil-branch-int glil-branch-label
  62
  63    <glil-call> make-glil-call glil-call?
  64    glil-call-int glil-call-nargs))
  65
  66 (define-record (<glil-vars> nargs nrest nlocs nexts))
  67
  68 (define-type <glil>
  69   (|
  70    ;; Meta operations
  71    (<glil-asm> vars body)
  72    (<glil-bind> vars)
  73    (<glil-unbind>)
  74    (<glil-source> loc)
  75    ;; Objects
  76    (<glil-void>)
  77    (<glil-const> obj)
  78    ;; Variables
  79    (<glil-argument> op index)
  80    (<glil-local> op index)
  81    (<glil-external> op depth index)
  82    (<glil-module> op module name)
  83    ;; Controls
  84    (<glil-label> label)
  85    (<glil-branch> inst label)
  86    (<glil-call> inst nargs)))
  87
  88 \f
  89 ;;;
  90 ;;; Parser
  91 ;;;
  92
  93 ;;; (define (parse-glil x)
  94 ;;;   (match x
  95 ;;;     (('@asm args . body)
  96 ;;;      (let* ((env (make-new-env e))
  97 ;;;         (args (parse-args args env)))
  98 ;;;        (make-asm env args (map-parse body env))))
  99 ;;;     (else
 100 ;;;      (error "Invalid assembly code:" x))))
 101 ;;;
 102 ;;; (define (parse-args x e)
 103 ;;;   (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
 104 ;;;                 ((list? x) (make-args (map make-local-var x) #f))
 105 ;;;                 (else (let loop ((l x) (v '()))
 106 ;;;                         (if (pair? l)
 107 ;;;                             (loop (cdr l) (cons (car l) v))
 108 ;;;                             (make-args (map make-local-var
 109 ;;;                                             (reverse! (cons l v)))
 110 ;;;                                        #t)))))))
 111 ;;;     (for-each (lambda (v) (env-add! e v)) (args-vars args))
 112 ;;;     args))
 113 ;;;
 114 ;;; (define (map-parse x e)
 115 ;;;   (map (lambda (x) (parse x e)) x))
 116 ;;;
 117 ;;; (define (parse x e)
 118 ;;;   (match x
 119 ;;;     ;; (@asm ARGS BODY...)
 120 ;;;     (('@asm args . body)
 121 ;;;      (parse-asm x e))
 122 ;;;     ;; (@bind VARS BODY...)
 123 ;;;     ;; (@block VARS BODY...)
 124 ;;;     (((or '@bind '@block) vars . body)
 125 ;;;      (let* ((offset (env-nvars e))
 126 ;;;         (vars (args-vars (parse-args vars e)))
 127 ;;;         (block (make-block (car x) offset vars (map-parse body e))))
 128 ;;;        (for-each (lambda (v) (env-remove! e)) vars)
 129 ;;;        block))
 130 ;;;     ;; (void)
 131 ;;;     (('void)
 132 ;;;      (make-void))
 133 ;;;     ;; (const OBJ)
 134 ;;;     (('const obj)
 135 ;;;      (make-const obj))
 136 ;;;     ;; (ref NAME)
 137 ;;;     ;; (set NAME)
 138 ;;;     (((or 'ref 'set) name)
 139 ;;;      (make-access (car x) (env-ref e name)))
 140 ;;;     ;; (label LABEL)
 141 ;;;     (('label label)
 142 ;;;      (make-label label))
 143 ;;;     ;; (br-if LABEL)
 144 ;;;     ;; (jump LABEL)
 145 ;;;     (((or 'br-if 'jump) label)
 146 ;;;      (make-instl (car x) label))
 147 ;;;     ;; (call NARGS)
 148 ;;;     ;; (tail-call NARGS)
 149 ;;;     (((or 'call 'tail-call) n)
 150 ;;;      (make-instn (car x) n))
 151 ;;;     ;; (INST)
 152 ;;;     ((inst)
 153 ;;;      (if (instruction? inst)
 154 ;;;      (make-inst inst)
 155 ;;;      (error "Unknown instruction:" inst)))))
 156
 157 \f
 158 ;;;
 159 ;;; Unparser
 160 ;;;
 161
 162 (define (unparse glil)
 163   (record-case glil
 164     ;; meta
 165     ((<glil-asm> vars body)
 166      `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
 167              ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
 168             ,@(map unparse body)))
 169     ((<glil-bind> vars) `(@bind ,@vars))
 170     ((<glil-unbind>) `(@unbind))
 171     ((<glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
 172     ;; constants
 173     ((<glil-void>) `(void))
 174     ((<glil-const> obj) `(const ,obj))
 175     ;; variables
 176     ((<glil-argument> op index)
 177      `(,(symbol-append 'argument- op) ,index))
 178     ((<glil-local> op index)
 179      `(,(symbol-append 'local- op) ,index))
 180     ((<glil-external> op depth index)
 181      `(,(symbol-append 'external- op) ,depth ,index))
 182     ((<glil-module> op module name)
 183      `(,(symbol-append 'module- op) ,module ,name))
 184     ;; controls
 185     ((<glil-label> label) label)
 186     ((<glil-branch> inst label) `(,inst ,label))
 187     ((<glil-call> inst nargs) `(,inst ,nargs))))
 188
 189 \f
 190 ;;;
 191 ;;; Printer
 192 ;;;
 193
 194 (define (pprint-glil glil . port)
 195   (let ((port (if (pair? port) (car port) (current-output-port))))
 196     (let print ((code (unparse glil)) (column 0))
 197       (display (make-string column #\space) port)
 198       (cond ((and (pair? code) (eq? (car code) '@asm))
 199              (format port "(@asm ~A\n" (cadr code))
 200              (let ((col (+ column 2)))
 201                (let loop ((l (cddr code)))
 202                  (print (car l) col)
 203                  (if (null? (cdr l))
 204                    (display ")" port)
 205                    (begin (newline port) (loop (cdr l)))))))
 206             (else (write code port))))
 207     (newline port)))