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