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