module/language/ghil/def.scm

   1 ;;; Guile High 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 (language ghil def)
  23   #:use-module (system base syntax)
  24   #:use-module (system base pmatch)
  25   #:use-module (ice-9 regex)
  26   #:export
  27   (<ghil-void> make-ghil-void ghil-void?
  28    ghil-void-env ghil-void-loc
  29
  30    <ghil-quote> make-ghil-quote ghil-quote?
  31    ghil-quote-env ghil-quote-loc ghil-quote-obj
  32
  33    <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
  34    ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
  35
  36    <ghil-unquote> make-ghil-unquote ghil-unquote?
  37    ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
  38
  39    <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
  40    ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
  41
  42    <ghil-ref> make-ghil-ref ghil-ref?
  43    ghil-ref-env ghil-ref-loc ghil-ref-var
  44
  45    <ghil-set> make-ghil-set ghil-set?
  46    ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
  47
  48    <ghil-define> make-ghil-define ghil-define?
  49    ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
  50
  51    <ghil-if> make-ghil-if ghil-if?
  52    ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
  53
  54    <ghil-and> make-ghil-and ghil-and?
  55    ghil-and-env ghil-and-loc ghil-and-exps
  56
  57    <ghil-or> make-ghil-or ghil-or?
  58    ghil-or-env ghil-or-loc ghil-or-exps
  59
  60    <ghil-begin> make-ghil-begin ghil-begin?
  61    ghil-begin-env ghil-begin-loc ghil-begin-exps
  62
  63    <ghil-bind> make-ghil-bind ghil-bind?
  64    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
  65
  66    <ghil-mv-bind> make-ghil-mv-bind ghil-mv-bind?
  67    ghil-mv-bind-env ghil-mv-bind-loc ghil-mv-bind-producer ghil-mv-bind-vars ghil-mv-bind-rest ghil-mv-bind-body
  68
  69    <ghil-lambda> make-ghil-lambda ghil-lambda?
  70    ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
  71    ghil-lambda-meta ghil-lambda-body
  72
  73    <ghil-inline> make-ghil-inline ghil-inline?
  74    ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
  75
  76    <ghil-call> make-ghil-call ghil-call?
  77    ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
  78
  79    <ghil-mv-call> make-ghil-mv-call ghil-mv-call?
  80    ghil-mv-call-env ghil-mv-call-loc ghil-mv-call-producer ghil-mv-call-consumer
  81
  82    <ghil-values> make-ghil-values ghil-values?
  83    ghil-values-env ghil-values-loc ghil-values-values
  84
  85    <ghil-values*> make-ghil-values* ghil-values*?
  86    ghil-values*-env ghil-values*-loc ghil-values*-values
  87
  88    <ghil-var> make-ghil-var ghil-var?
  89    ghil-var-env ghil-var-name ghil-var-kind ghil-var-index
  90
  91    <ghil-toplevel-env> make-ghil-toplevel-env ghil-toplevel-env?
  92    ghil-toplevel-env-table
  93
  94    <ghil-env> make-ghil-env ghil-env?
  95    ghil-env-parent ghil-env-table ghil-env-variables
  96
  97    <ghil-reified-env> make-ghil-reified-env ghil-reified-env?
  98    ghil-reified-env-env ghil-reified-env-loc
  99
 100    ghil-env-add!
 101    ghil-env-reify ghil-env-dereify
 102    ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
 103    ghil-var-at-module!
 104    call-with-ghil-environment call-with-ghil-bindings
 105
 106    parse-ghil unparse-ghil))
 107
 108 \f
 109 ;;;
 110 ;;; Parse tree
 111 ;;;
 112
 113 (define (print-ghil x port)
 114   (format port "#<ghil ~s>" (unparse-ghil x)))
 115
 116 (define-type (<ghil> #:printer print-ghil)
 117   ;; Objects
 118   (<ghil-void> env loc)
 119   (<ghil-quote> env loc obj)
 120   (<ghil-quasiquote> env loc exp)
 121   (<ghil-unquote> env loc exp)
 122   (<ghil-unquote-splicing> env loc exp)
 123   ;; Variables
 124   (<ghil-ref> env loc var)
 125   (<ghil-set> env loc var val)
 126   (<ghil-define> env loc var val)
 127   ;; Controls
 128   (<ghil-if> env loc test then else)
 129   (<ghil-and> env loc exps)
 130   (<ghil-or> env loc exps)
 131   (<ghil-begin> env loc exps)
 132   (<ghil-bind> env loc vars vals body)
 133   (<ghil-mv-bind> env loc producer vars rest body)
 134   (<ghil-lambda> env loc vars rest meta body)
 135   (<ghil-call> env loc proc args)
 136   (<ghil-mv-call> env loc producer consumer)
 137   (<ghil-inline> env loc inline args)
 138   (<ghil-values> env loc values)
 139   (<ghil-values*> env loc values)
 140   (<ghil-reified-env> env loc))
 141
 142
 143 \f
 144 ;;;
 145 ;;; Variables
 146 ;;;
 147
 148 (define-record <ghil-var> env name kind (index #f))
 149
 150 \f
 151 ;;;
 152 ;;; Modules
 153 ;;;
 154
 155 \f
 156 ;;;
 157 ;;; Environments
 158 ;;;
 159
 160 (define-record <ghil-env> parent (table '()) (variables '()))
 161 (define-record <ghil-toplevel-env> (table '()))
 162
 163 (define (ghil-env-ref env sym)
 164   (assq-ref (ghil-env-table env) sym))
 165
 166 (define-macro (push! item loc)
 167   `(set! ,loc (cons ,item ,loc)))
 168 (define-macro (apush! k v loc)
 169   `(set! ,loc (acons ,k ,v ,loc)))
 170 (define-macro (apopq! k loc)
 171   `(set! ,loc (assq-remove! ,loc ,k)))
 172
 173 (define (ghil-env-add! env var)
 174   (apush! (ghil-var-name var) var (ghil-env-table env))
 175   (push! var (ghil-env-variables env)))
 176
 177 (define (ghil-env-remove! env var)
 178   (apopq! (ghil-var-name var) (ghil-env-table env)))
 179
 180 (define (force-heap-allocation! var)
 181   (set! (ghil-var-kind var) 'external))
 182
 183
 184 \f
 185 ;;;
 186 ;;; Public interface
 187 ;;;
 188
 189 ;; The following four functions used to be one, in ghil-lookup. Now they
 190 ;; are four, to reflect the different intents. A bit of duplication, but
 191 ;; that's OK. The common current is to find out where a variable will be
 192 ;; stored at runtime.
 193 ;;
 194 ;; These functions first search the lexical environments. If the
 195 ;; variable is not in the innermost environment, make sure the variable
 196 ;; is marked as being "external" so that it goes on the heap. If the
 197 ;; variable is being modified (via a set!), also make sure it's on the
 198 ;; heap, so that other continuations see the changes to the var.
 199 ;;
 200 ;; If the variable is not found lexically, it is a toplevel variable,
 201 ;; which will be looked up at runtime with respect to the module that
 202 ;; was current when the lambda was bound, at runtime. The variable will
 203 ;; be resolved when it is first used.
 204 (define (ghil-var-is-bound? env sym)
 205   (let loop ((e env))
 206     (record-case e
 207       ((<ghil-toplevel-env> table)
 208        (let ((key (cons (module-name (current-module)) sym)))
 209          (assoc-ref table key)))
 210       ((<ghil-env> parent table variables)
 211        (and (not (assq-ref table sym))
 212             (loop parent))))))
 213
 214 (define (ghil-var-for-ref! env sym)
 215   (let loop ((e env))
 216     (record-case e
 217       ((<ghil-toplevel-env> table)
 218        (let ((key (cons (module-name (current-module)) sym)))
 219          (or (assoc-ref table key)
 220              (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 221                (apush! key var (ghil-toplevel-env-table e))
 222                var))))
 223       ((<ghil-env> parent table variables)
 224        (cond
 225         ((assq-ref table sym)
 226          => (lambda (var)
 227               (or (eq? e env)
 228                   (force-heap-allocation! var))
 229               var))
 230         (else
 231          (loop parent)))))))
 232
 233 (define (ghil-var-for-set! env sym)
 234   (let loop ((e env))
 235     (record-case e
 236       ((<ghil-toplevel-env> table)
 237        (let ((key (cons (module-name (current-module)) sym)))
 238          (or (assoc-ref table key)
 239              (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 240                (apush! key var (ghil-toplevel-env-table e))
 241                var))))
 242       ((<ghil-env> parent table variables)
 243        (cond
 244         ((assq-ref table sym)
 245          => (lambda (var)
 246               (force-heap-allocation! var)
 247               var))
 248         (else
 249          (loop parent)))))))
 250
 251 (define (ghil-var-at-module! env modname sym interface?)
 252   (let loop ((e env))
 253     (record-case e
 254       ((<ghil-toplevel-env> table)
 255        (let ((key (list modname sym interface?)))
 256          (or (assoc-ref table key)
 257              (let ((var (make-ghil-var modname sym
 258                                        (if interface? 'public 'private))))
 259                (apush! key var (ghil-toplevel-env-table e))
 260                var))))
 261       ((<ghil-env> parent table variables)
 262        (loop parent)))))
 263
 264 (define (ghil-var-define! toplevel sym)
 265   (let ((key (cons (module-name (current-module)) sym)))
 266     (or (assoc-ref (ghil-toplevel-env-table toplevel) key)
 267         (let ((var (make-ghil-var (car key) (cdr key) 'toplevel)))
 268           (apush! key var (ghil-toplevel-env-table toplevel))
 269           var))))
 270
 271 (define (call-with-ghil-environment e syms func)
 272   (let* ((e (make-ghil-env e))
 273          (vars (map (lambda (s)
 274                       (let ((v (make-ghil-var e s 'argument)))
 275                         (ghil-env-add! e v) v))
 276                     syms)))
 277     (func e vars)))
 278
 279 (define (call-with-ghil-bindings e syms func)
 280   (let* ((vars (map (lambda (s)
 281                       (let ((v (make-ghil-var e s 'local)))
 282                         (ghil-env-add! e v) v))
 283                     syms))
 284          (ret (func vars)))
 285     (for-each (lambda (v) (ghil-env-remove! e v)) vars)
 286     ret))
 287
 288 (define (ghil-env-reify env)
 289   (let loop ((e env) (out '()))
 290     (record-case e
 291       ((<ghil-toplevel-env> table)
 292        (map (lambda (v)
 293               (cons (ghil-var-name v)
 294                     (or (ghil-var-index v)
 295                         (error "reify called before indices finalized"))))
 296             out))
 297       ((<ghil-env> parent table variables)
 298        (loop parent
 299              (append out
 300                      (filter (lambda (v) (eq? (ghil-var-kind v) 'external))
 301                              variables)))))))
 302
 303 (define (ghil-env-dereify name-index-alist)
 304   (let* ((e (make-ghil-env (make-ghil-toplevel-env)))
 305          (vars (map (lambda (pair)
 306                       (make-ghil-var e (car pair) 'external (cdr pair)))
 307                     name-index-alist)))
 308     (set! (ghil-env-table e)
 309           (map (lambda (v) (cons (ghil-var-name v) v)) vars))
 310     (set! (ghil-env-variables e) vars)
 311     e))
 312
 313 \f
 314 ;;;
 315 ;;; Parser
 316 ;;;
 317
 318 (define (location x)
 319   (and (pair? x)
 320        (let ((props (source-properties x)))
 321          (and (not (null? props))
 322               (vector (assq-ref props 'line)
 323                       (assq-ref props 'column)
 324                       (assq-ref props 'filename))))))
 325
 326 (define (parse-quasiquote e x level)
 327   (cond ((not (pair? x)) x)
 328         ((memq (car x) '(unquote unquote-splicing))
 329          (let ((l (location x)))
 330            (pmatch (cdr x)
 331              ((,obj)
 332               (cond
 333                ((zero? level)
 334                 (if (eq? (car x) 'unquote)
 335                     (make-ghil-unquote e l (parse-ghil e obj))
 336                     (make-ghil-unquote-splicing e l (parse-ghil e obj))))
 337                (else
 338                 (list (car x) (parse-quasiquote e obj (1- level))))))
 339              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 340         ((eq? (car x) 'quasiquote)
 341          (let ((l (location x)))
 342            (pmatch (cdr x)
 343              ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
 344              (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 345         (else (cons (parse-quasiquote e (car x) level)
 346                     (parse-quasiquote e (cdr x) level)))))
 347
 348 (define (parse-ghil env exp)
 349   (let ((loc (location exp))
 350         (retrans (lambda (x) (parse-ghil env x))))
 351     (pmatch exp
 352      (,exp (guard (symbol? exp))
 353            (make-ghil-ref env #f (ghil-var-for-ref! env exp)))
 354
 355      (,exp (guard (not (pair? exp)))
 356            (make-ghil-quote #:env env #:loc #f #:obj exp))
 357
 358      (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
 359
 360      ((void) (make-ghil-void env loc))
 361
 362      ((lambda ,syms ,rest ,meta . ,body)
 363       (call-with-ghil-environment env syms
 364         (lambda (env vars)
 365           (make-ghil-lambda env loc vars rest meta
 366                             (parse-ghil env `(begin ,@body))))))
 367
 368      ((begin . ,body)
 369       (make-ghil-begin env loc (map retrans body)))
 370
 371      ((bind ,syms ,exprs . ,body)
 372       (let ((vals (map retrans exprs)))
 373         (call-with-ghil-bindings env syms
 374           (lambda (vars)
 375             (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
 376
 377      ((bindrec ,syms ,exprs . ,body)
 378       (call-with-ghil-bindings env syms
 379         (lambda (vars)
 380           (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
 381             (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
 382
 383      ((set! ,sym ,val)
 384       (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
 385
 386      ((define ,sym ,val)
 387       (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
 388
 389      ((if ,test ,then ,else)
 390       (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
 391
 392      ((and . ,exps)
 393       (make-ghil-and env loc (map retrans exps)))
 394
 395      ((or . ,exps)
 396       (make-ghil-or env loc (map retrans exps)))
 397
 398      ((mv-bind ,syms ,rest ,producer . ,body)
 399       (call-with-ghil-bindings env syms
 400         (lambda (vars)
 401           (make-ghil-mv-bind env loc (retrans producer) vars rest
 402                              (map retrans body)))))
 403
 404      ((call ,proc . ,args)
 405       (make-ghil-call env loc (retrans proc) (map retrans args)))
 406
 407      ((mv-call ,producer . ,consumer)
 408       (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
 409
 410      ((inline ,op . ,args)
 411       (make-ghil-inline env loc op (map retrans args)))
 412
 413      ((values . ,values)
 414       (make-ghil-values env loc (map retrans values)))
 415
 416      ((values* . ,values)
 417       (make-ghil-values* env loc (map retrans values)))
 418
 419      ((compile-time-environment)
 420       (make-ghil-reified-env env loc))
 421
 422      ((quasiquote ,exp)
 423       (make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
 424
 425      (else
 426       (error "unrecognized GHIL" exp)))))
 427
 428 (define (unparse-ghil ghil)
 429   (record-case ghil
 430     ((<ghil-void> env loc)
 431      '(void))
 432     ((<ghil-quote> env loc obj)
 433      (if (symbol? obj)
 434          `(,'quote ,obj)
 435          obj))
 436     ((<ghil-quasiquote> env loc exp)
 437      `(,'quasiquote ,(map unparse-ghil exp)))
 438     ((<ghil-unquote> env loc exp)
 439      `(,'unquote ,(unparse-ghil exp)))
 440     ((<ghil-unquote-splicing> env loc exp)
 441      `(,'unquote-splicing ,(unparse-ghil exp)))
 442   ;; Variables
 443     ((<ghil-ref> env loc var)
 444      (ghil-var-name var))
 445     ((<ghil-set> env loc var val)
 446      `(set! ,(ghil-var-name var) ,(unparse-ghil val)))
 447     ((<ghil-define> env loc var val)
 448      `(define ,(ghil-var-name var) ,(unparse-ghil val)))
 449   ;; Controls
 450     ((<ghil-if> env loc test then else)
 451      `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
 452     ((<ghil-and> env loc exps)
 453      `(and ,@(map unparse-ghil exps)))
 454     ((<ghil-or> env loc exps)
 455      `(or ,@(map unparse-ghil exps)))
 456     ((<ghil-begin> env loc exps)
 457      `(begin ,@(map unparse-ghil exps)))
 458     ((<ghil-bind> env loc vars vals body)
 459      `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
 460             ,@(map unparse-ghil body)))
 461     ((<ghil-mv-bind> env loc producer vars rest body)
 462      `(mv-bind ,(map ghil-var-name vars) ,rest
 463                ,(unparse-ghil producer) ,@(map unparse-ghil body)))
 464     ((<ghil-lambda> env loc vars rest meta body)
 465      `(lambda ,(map ghil-var-name vars) ,rest ,meta
 466               ,(unparse-ghil body)))
 467     ((<ghil-call> env loc proc args)
 468      `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
 469     ((<ghil-mv-call> env loc producer consumer)
 470      `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
 471     ((<ghil-inline> env loc inline args)
 472      `(inline ,inline ,@(map unparse-ghil args)))
 473     ((<ghil-values> env loc values)
 474      `(values ,@(map unparse-ghil values)))
 475     ((<ghil-values*> env loc values)
 476      `(values* ,@(map unparse-ghil values)))
 477     ((<ghil-reified-env> env loc)
 478      `(compile-time-environment))))