home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / front_end / computed_goto.t < prev    next >
Encoding:
Text File  |  1990-05-21  |  11.5 KB  |  316 lines
  1. (herald computed_goto)
  2.  
  3. (define (simplify-computed-goto call)
  4.   (simplify (nthcdr (call-proc+args call)  ; simplify the default
  5.             (call-exits call)))
  6.   (let ((next (iterate loop ((n (goto-default call)))
  7.         (cond ((not (lambda-node? n)) '#f)
  8.               ((lambda-node? (call-proc (lambda-body n)))
  9.                (loop (call-proc (lambda-body n))))
  10.               (else (lambda-body n)))))
  11.     (var (reference-variable (goto-index call))))
  12.     (cond ((not next) '#f)
  13. ;        ((similar-eq?-call? next var)  ; should probably do this as well
  14. ;         (make-goto-call var call next))
  15.       ((similar-goto-call? next var)
  16.        (join-two-gotos call next))
  17.       (else '#f))))
  18.  
  19. (define (goto-keys call)
  20.   ((call-arg (fx+ 2 (call-exits call))) call))
  21.  
  22. (define (goto-default call)
  23.   ((call-arg (call-exits call)) call))
  24.  
  25. (define (goto-index call)
  26.   ((call-arg (fx+ 1 (call-exits call))) call))
  27.  
  28. (define (join-two-gotos first second)
  29.   (let ((keys1 (literal-value (goto-keys first)))
  30.     (keys2 (literal-value (goto-keys second)))
  31.     (args1 (call-args first))
  32.     (args2 (call-args second))
  33.     (first-default (goto-default first))
  34.     (second-default (goto-default second)))
  35.     (iterate loop ((keys2 keys2) (args2 args2) (args args1) (keys keys1))
  36.       (cond ((null? keys2)
  37.          (let ((new (create-call-node (fx+ 1 (length args))
  38.                       (fx- (length args) 2))))
  39.            (relate-call-args new (map detach args))
  40.            (set (call-proc new) (detach (call-proc first)))
  41.            (set (literal-value (goto-keys new)) keys)
  42.            (replace first (detach (lambda-body first-default)))
  43.            (replace first-default (detach second-default))
  44.            (replace second new)
  45.            '#t))
  46.         ((memq? (car keys2) keys1)
  47.          (loop (cdr keys2) (cdr args2) args keys))
  48.         (else
  49.          (loop (cdr keys2) (cdr args2)
  50.            (cons (car args2) args)
  51.            (cons (car keys2) keys)))))))
  52.  
  53. ; If both values are constants, then replace with the appropriate continuation.
  54. ; Otherwise check for testing an identifier against a fixnum.
  55.  
  56. (define (simplify-eq? call)
  57.   (let ((arg1 ((call-arg '4) call))
  58.         (arg2 ((call-arg '5) call)))
  59.     (cond ((and (literal-node? arg1)
  60.                 (literal-node? arg2))
  61.            (let ((proc ((call-arg (if (eq? (literal-value arg1)
  62.                                            (literal-value arg2))
  63.                                       '1
  64.                                       '2))
  65.                         call))
  66.                  (new (create-call-node '1 '1)))
  67.              (detach proc)
  68.              (relate call-proc new proc)
  69.              (replace call new)
  70.              '#t))
  71.           ((and (literal-node? arg1)
  72.                 (fixnum? (literal-value arg1))
  73.                 (reference-node? arg2))
  74.            (eq?->goto call arg2))
  75.           ((and (literal-node? arg2)
  76.                 (fixnum? (literal-value arg2))
  77.                 (reference-node? arg1))
  78.            (eq?->goto call arg1))
  79.           (else '#f))))
  80.  
  81. ; Go down the false branch looking for either a test of the same
  82. ; identifier or a call to $COMPUTED-GOTO
  83.  
  84. (define (eq?->goto call ref)
  85.   (simplify (cdr (call-args call)))
  86.   (let ((var (reference-variable ref))
  87.         (next (iterate loop ((n ((call-arg '2) call)))
  88.                 (cond ((not (lambda-node? n)) '#f)
  89.                       ((lambda-node? (call-proc (lambda-body n)))
  90.                        (loop (call-proc (lambda-body n))))
  91.                       (else (lambda-body n))))))
  92.     (cond ((not next) '#f)
  93.           ((similar-eq?-call? next var)
  94.            (make-goto-call var call next))
  95.           ((similar-goto-call? next var)
  96.            (add-to-goto next call))
  97.           (else '#f))))
  98.  
  99. ; Is CALL checking for equality between an identifier and a fixnum?
  100.  
  101. (define (similar-eq?-call? call var)
  102.   (and (primop-ref? (call-proc call) primop/conditional)
  103.        (eq? 'eq? (primop.id (primop-value ((call-arg '3) call))))
  104.        (or (eq?-arg-check call var '4 '5)
  105.            (eq?-arg-check call var '5 '4))))
  106.   
  107. (define (eq?-arg-check call var i1 i2)
  108.   (let ((arg1 ((call-arg i1) call))
  109.         (arg2 ((call-arg i2) call)))
  110.     (and (reference-node? arg1)
  111.          (eq? var (reference-variable arg1))
  112.          (literal-node? arg2)
  113.          (fixnum? (literal-value arg2)))))
  114.  
  115. ; Is CALL a computed goto on the value of VAR?
  116.  
  117. (define (similar-goto-call? call var)
  118.   (and (id-primop-ref? (call-proc call) 'computed-goto)
  119.        (let ((test ((call-arg (fx+ '1 (call-exits call))) call)))
  120.          (and (reference-node? test)
  121.               (eq? var (reference-variable test))))))
  122.  
  123. ; ($COND 2 <t1> (LAMBDA () <f1>) $EQ? <var> <int>)
  124. ;   =>
  125. ; <f1>
  126. ;
  127. ; <f1>: ... ($COND 2 <t2> <f2> $EQ? <var> <int2>) ...
  128. ;   =>
  129. ;     ... ($COMPUTED-GOTO 3 <t1> <t2> <f2> <var> '(<int1> <int2>)) ...
  130. ;
  131. ; 2 comes before 1 in the GOTO call to preserve the inverse mapping between
  132. ; the exits of the GOTO and the execution order.
  133.  
  134. (define (make-goto-call var upper lower)
  135.   (receive (int1 true1 false1)
  136.            (destructure-eq? upper)
  137.     (receive (int2 true2 false2)
  138.              (destructure-eq? lower)
  139.       (let ((primop (get-primop 'computed-goto))
  140.             (keys (list int2 int1)))
  141.         (let-nodes ((c (($ primop) 3 true2 true1 false2 (* var) 'keys)))
  142.           (replace upper (detach (lambda-body false1)))
  143.           (erase-all false1)
  144.           (replace lower c)
  145.           '#t)))))
  146.  
  147. (define (destructure-eq? call)
  148.   (destructure (((true false #f a1 a2) (call-args call)))
  149.     (return (literal-value (if (literal-node? a1) a1 a2))
  150.             (detach true)
  151.             (detach false))))
  152.  
  153. ; ($COND 2 <true> (LAMBDA () <false>) $EQ? <var> <int>)
  154. ;   =>
  155. ; <false>
  156. ;
  157. ; f1: ... ($COMPUTED-GOTO N ... <var> '(...)) ...
  158. ;   =>
  159. ;     ... ($COMPUTED-GOTO N+1 <true>  ... <var> '(<int> ...)) ...
  160. ;
  161. ; If the new value is already in the list, replace the old exit with the
  162. ; new one.
  163.  
  164. (define (add-to-goto call eq?-call)
  165.   (let ((exits (call-exits call)))
  166.     (receive (int true false)
  167.              (destructure-eq? eq?-call)
  168.       (replace eq?-call (detach (lambda-body false)))
  169.       (erase-all false)
  170.       (let* ((values-node ((call-arg (fx+ exits '2)) call))
  171.              (values (literal-value values-node)))
  172.         (cond ((memq? int values)
  173.                (do ((vals values (cdr vals))
  174.                     (exits (call-args call) (cdr exits)))
  175.                    ((fx= int (car vals))
  176.                     (replace (car exits) true))))
  177.               (else
  178.                (set (literal-value values-node) (cons int values))
  179.                (set (call-exits call) (fx+ exits '1))
  180.                (let ((args (map detach (call-args call))))
  181.                  (modify (cdr (call-proc+args call))
  182.                          (lambda (l) (cons empty l)))
  183.                  (relate-call-args call (cons true args)))))
  184.         '#t))))
  185.  
  186. ;;;============================================================================
  187.  
  188. ;;; Part two, fixup code to turn unnecessary computed gotos back into calls
  189. ;;; to EQ?
  190.  
  191. (define computed-goto-minimum-size '5)
  192. (define computed-goto-miminum-density '0.5)
  193.  
  194. ; Simplifier version:
  195. ;   ($COMPUTED-GOTO n <cont0> ... <contN-2> <miss> <i> <list of ints>)
  196. ;
  197. ; Code generation version:
  198. ;   ($COMPUTED-GOTO n <cont0> ... <contN-2> <i>)
  199. ; 
  200. ; 1) Break up sparse GOTOs into calls to EQ? and smaller GOTOs
  201. ; 2) Each remaining GOTO needs range-check calls and base arithmetic
  202. ;
  203. ; DATA is a list of (<index> <integer> <action>) lists
  204.  
  205. (define (fixup-computed-goto call)
  206.   (let* ((exits (call-exits call))
  207.          (fail (detach             ((call-arg         exits)  call)))
  208.          (var  (reference-variable ((call-arg (fx+ '1 exits)) call)))
  209.          (ints (literal-value      ((call-arg (fx+ '2 exits)) call)))
  210.          (data (do ((i '0 (fx+ i '1))
  211.                     (ints ints (cdr ints))
  212.                     (args (call-args call) (cdr args))
  213.                     (ls '() (cons (list i (car ints) (detach (car args))) ls)))
  214.                    ((null? ints)
  215.                     (sort-list! ls (lambda (a b) (fx<= (cadr a) (cadr b)))))))
  216.          (min (cadar data))
  217.          (max (cadr (last data)))
  218.          (density (/ (fx- exits '1) (fx+ (fx- max min) '1))))
  219.     (replace call (if (and (fx> exits computed-goto-minimum-size)
  220.                            (> density computed-goto-miminum-density))
  221.                       (rebuild-computed-goto data min max fail var)
  222.                       (computed-goto->eq?s data fail var)))))
  223.  
  224. ; ($COMPUTED-GOTO n <cont0> ... <contN-2> <miss> <i> <list of ints>)
  225. ;   =>
  226. ; (LET ((M <miss>)
  227. ;       (I (FX- <i> <low>)))
  228. ;   ($FX< M ^1 I '0))
  229. ; ^1 = (LAMBDA () ($FX< ^2 M '(- <high> <low>) I))
  230. ; ^2 = (LAMBDA () ($COMPUTED-GOTO M <contx0> ... <contxM-1> I))
  231.  
  232. ; PAIRS is a list of (<index> . <lambda-node>) pairs.
  233.  
  234. (define (rebuild-computed-goto data low high fail-node tested-var)
  235.   (let* ((fail (if (lambda-node? fail-node)
  236.                    (create-variable 'f)
  237.                    (reference-variable fail-node)))
  238.          (t-var (if (fx= '0 low) tested-var (create-variable 't)))
  239.          (args (create-goto-args data low t-var fail))
  240.          (size (fx+ (fx- high low) '1))
  241.          (call (create-call-node (fx+ size '2) size)))
  242.     (relate call-proc call (create-primop-node (get-primop 'computed-goto)))
  243.     (relate-call-args call args)
  244.     (let ((condp (get-primop 'conditional))
  245.           (testp (get-primop 'fixnum-less?))
  246.           (diff (fx+ (fx- high low) '1))
  247.           (f1 (wrap-in-lambda (create-reference-node fail)))
  248.           (f2 (wrap-in-lambda (create-reference-node fail))))
  249.       (let-nodes ((new   (($ condp) 2 f1 l1 ($ testp) (* t-var) '0))
  250.                   (l1 () (($ condp) 2 l2 f2 ($ testp) (* t-var) 'diff))
  251.                   (l2 () call))
  252.         (let ((new (cond ((lambda-node? fail-node)
  253.                           (bind-goto-fail new fail-node fail))
  254.                          (else
  255.                           (erase-all fail)
  256.                           new))))
  257.           (if (fx= low '0)
  258.               new
  259.               (subtract-goto-base new low tested-var t-var)))))))
  260.  
  261. (define (create-goto-args data low test-var fail-var)
  262.   (let ((test (create-reference-node test-var)))
  263.     (iterate loop ((data data) (i low) (args '()))
  264.       (cond ((null? data)
  265.              (reverse! (cons test (map! wrap-in-lambda args))))
  266.             ((fx= i (cadar data))
  267.              (loop (cdr data)
  268.                    (fx+ i '1)
  269.                    (cons (caddar data) args)))
  270.             (else
  271.              (loop data
  272.                    (fx+ i '1)
  273.                    (cons (create-reference-node fail-var) args)))))))
  274.  
  275. (define (bind-goto-fail call value var)
  276.   (let-nodes ((new (l1 0 value))
  277.               (l1 (#f (var var)) call))
  278.     new))
  279.  
  280. (define (subtract-goto-base call offset from result)
  281.   (let ((primop (get-primop 'fixnum-subtract)))
  282.     (let-nodes ((new (($ primop) 1 cont (* from) 'offset))
  283.                 (cont (#f (x result)) call))
  284.       new)))
  285.  
  286. ; Turn a GOTO into a series of EQ? tests.
  287.  
  288. (define (computed-goto->eq?s data fail var)
  289.   (let ((data (sort-list! data (lambda (a b) (fx> (car a) (car b)))))
  290.         (call (detach (lambda-body fail)))
  291.         (cond (get-primop 'conditional))
  292.         (eq   (get-primop 'eq?)))
  293.     (erase-all fail)
  294.     (iterate loop ((data data) (call call))
  295.       (if (null? data)
  296.           call
  297.           (destructure ((((#f int exit) . rest) data))
  298.             (let ((exit (wrap-in-lambda exit)))
  299.               (let-nodes ((new (($ cond) 2 exit false ($ eq) (* var) 'int))
  300.                           (false () call))
  301.                 (loop rest new))))))))
  302.  
  303. (define (wrap-in-lambda node)
  304.   (if (lambda-node? node)
  305.       node
  306.      (let-nodes ((l1 () (node 0)))
  307.        l1)))
  308.  
  309. (define (id-primop-ref? node id)
  310.   (and (primop-node? node)
  311.        (eq? id (primop.id (primop-value node)))))
  312.  
  313. (define (get-primop id)
  314.   (let ((primop (table-entry primop-table id)))
  315.     (if primop primop (bug '"~S primop not found" id))))
  316.