context.scm

   1 ;;;; File: "context.scm", Time-stamp: <2006-05-08 16:04:37 feeley>
   2
   3 ;;;; Copyright (C) 2004-2009 by Marc Feeley and Vincent St-Amour
   4 ;;;; All Rights Reserved.
   5
   6 ;; Compilation context representation.
   7
   8 (define-type context
   9   code
  10   env
  11   env2
  12 )
  13
  14 (define context-change-code
  15   (lambda (ctx code)
  16     (make-context code
  17                   (context-env ctx)
  18                   (context-env2 ctx))))
  19
  20 (define context-change-env
  21   (lambda (ctx env)
  22     (make-context (context-code ctx)
  23                   env
  24                   (context-env2 ctx))))
  25
  26 (define context-change-env2
  27   (lambda (ctx env2)
  28     (make-context (context-code ctx)
  29                   (context-env ctx)
  30                   env2)))
  31
  32 (define make-init-context
  33   (lambda ()
  34     (make-context (make-init-code)
  35                   (make-init-env)
  36                   #f)))
  37
  38 (define context-make-label
  39   (lambda (ctx)
  40     (context-change-code ctx (code-make-label (context-code ctx)))))
  41
  42 (define context-last-label
  43   (lambda (ctx)
  44     (code-last-label (context-code ctx))))
  45
  46 (define context-add-bb
  47   (lambda (ctx label)
  48     (context-change-code ctx (code-add-bb (context-code ctx) label))))
  49
  50 (define context-add-instr
  51   (lambda (ctx instr)
  52     (context-change-code ctx (code-add-instr (context-code ctx) instr))))
  53
  54 ;; Representation of code.
  55
  56 (define-type code
  57   last-label
  58   rev-bbs
  59 )
  60
  61 (define-type bb
  62   label
  63   rev-instrs
  64 )
  65
  66 (define make-init-code
  67   (lambda ()
  68     (make-code 0
  69                (list (make-bb 0 (list))))))
  70
  71 (define code-make-label
  72   (lambda (code)
  73     (let ((label (+ (code-last-label code) 1)))
  74       (make-code label
  75                  (code-rev-bbs code)))))
  76
  77 (define code-add-bb
  78   (lambda (code label)
  79     (make-code
  80      (code-last-label code)
  81      (cons (make-bb label '())
  82            (code-rev-bbs code)))))
  83
  84 (define code-add-instr
  85   (lambda (code instr)
  86     (let* ((rev-bbs (code-rev-bbs code))
  87            (bb (car rev-bbs))
  88            (rev-instrs (bb-rev-instrs bb)))
  89       (make-code
  90        (code-last-label code)
  91        (cons (make-bb (bb-label bb)
  92                       (cons instr rev-instrs))
  93              (cdr rev-bbs))))))
  94
  95 ;; Representation of compile-time stack.
  96
  97 (define-type stack
  98   size  ; number of slots
  99   slots ; for each slot, the variable (or #f) contained in the slot
 100 )
 101
 102 (define make-init-stack
 103   (lambda ()
 104     (make-stack 0 '())))
 105
 106 (define stack-extend
 107   (lambda (x nb-slots stk)
 108     (let ((size (stack-size stk)))
 109       (make-stack
 110        (+ size nb-slots)
 111        (append (repeat nb-slots x) (stack-slots stk))))))
 112
 113 (define stack-discard
 114   (lambda (nb-slots stk)
 115     (let ((size (stack-size stk)))
 116       (make-stack
 117        (- size nb-slots)
 118        (list-tail (stack-slots stk) nb-slots)))))
 119
 120 ;; Representation of compile-time environment.
 121
 122 (define-type env
 123   local
 124   closed
 125 )
 126
 127 (define make-init-env
 128   (lambda ()
 129     (make-env (make-init-stack)
 130               '())))
 131
 132 (define env-change-local
 133   (lambda (env local)
 134     (make-env local
 135               (env-closed env))))
 136
 137 (define env-change-closed
 138   (lambda (env closed)
 139     (make-env (env-local env)
 140               closed)))
 141
 142 (define find-local-var
 143   (lambda (var env)
 144     (let ((i (pos-in-list var (stack-slots (env-local env)))))
 145       (or i
 146           (- (+ (pos-in-list var (env-closed env)) 1))))))
 147
 148 (define prc->env
 149   (lambda (prc)
 150     (make-env
 151      (let ((params (prc-params prc)))
 152        (make-stack (length params)
 153                    (append (map var-id params) '())))
 154      (let ((vars (varset->list (non-global-fv prc))))
 155 ;       (pp (map var-id vars))
 156        (map var-id vars)))))