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