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 / fx_const.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  8.2 KB  |  257 lines
  1. (herald fx_const)
  2.  
  3. ;;; Constant folding and reduction in strength for fixnum arithmetic.
  4.  
  5. ;;; To Do
  6. ;;; fixnum-equal?, fixnum-less?
  7. ;;; char=, char<
  8. ;;; char->ascii, ascii->char
  9.  
  10. ;;;                       UTILITIES
  11. ;;;============================================================================
  12.  
  13. ;;; Get the literal value of a node.  FIXNUM is a misnomer here.
  14.  
  15. (define (fixnum-value node)
  16.   (if (literal-node? node)
  17.       (literal-value node)
  18.       nil))
  19.  
  20. ;;; (PROC NODE ARG) => NODE if ARG is the arithmetic identity element for
  21. ;;; PROC.
  22.  
  23. (define (reduce-arith-identity call arg node ident)
  24.   (cond ((fx= arg ident)
  25.          (replace-call-with-value call (detach node))
  26.          t)
  27.         (else nil)))
  28.                                       
  29. ;;; Replace CALL with VAL if TEST is true.
  30.  
  31. (define (reduce-arith-no-op call test val)
  32.   (cond (test
  33.          (replace-call-with-value call (create-literal-node val))
  34.          t)
  35.         (else nil)))
  36.                                       
  37. ;;; If A1 and A2 are fixnums, then replace CALL with (PROC A1 A2).
  38.  
  39. (define (fixnum-constant-fold call a1 a2 proc)
  40.   (cond ((and a1 (not (fixnum? a1)))
  41.          (fix-user-error call
  42.                          '"type conflict, got ~S when expecting a fixnum"
  43.                          a1)
  44.          t)
  45.         ((and a2 (not (fixnum? a2)))
  46.          (fix-user-error call
  47.                          '"type conflict, got ~S when expecting a fixnum"
  48.                          a2)
  49.          t)
  50.         ((and a1 a2)
  51.          (replace-call-with-value call (create-literal-node (proc a1 a2)))
  52.          t)
  53.         (else nil)))
  54.  
  55. ;;; Are N1 and N2 references to the same variable?
  56.  
  57. (define (duplicate-args? n1 n2)
  58.   (and (reference-node? n1)
  59.        (reference-node? n2)
  60.        (eq? (reference-variable n1) (reference-variable n2))))
  61.  
  62. ;;;               Fixnum Constant Folding
  63. ;;;============================================================================
  64.  
  65. ;;;  (fx+ <fix>     0) => <fix>
  66. ;;;  (fx+     0 <fix>) => <fix>
  67.  
  68. (define (simplify-fixnum-add call)
  69.   (let* ((n1 ((call-arg 2) call))
  70.          (n2 ((call-arg 3) call))
  71.          (a1 (fixnum-value n1))
  72.          (a2 (fixnum-value n2)))
  73.     (cond ((fixnum-constant-fold call a1 a2 fixnum-add)
  74.            t)
  75.           (a1
  76.            (reduce-arith-identity call a1 n2 0))
  77.           (a2
  78.            (reduce-arith-identity call a2 n1 0))
  79.           (else nil))))
  80.  
  81. ;;;  (fx- <fix>     0) => <fix>
  82. ;;;  (fx- <fix> <fix>) => 0
  83.  
  84. (define (simplify-fixnum-subtract call)
  85.   (let* ((n1 ((call-arg 2) call))
  86.          (n2 ((call-arg 3) call))
  87.          (a1 (fixnum-value n1))
  88.          (a2 (fixnum-value n2)))
  89.     (cond ((fixnum-constant-fold call a1 a2 fixnum-subtract)
  90.            t)
  91.           (a2
  92.            (reduce-arith-identity call a2 n1 0))
  93.           ((duplicate-args? n1 n2)
  94.            (replace-call-with-value call (create-literal-node 0)))
  95.           (else nil))))
  96.  
  97. ;;;  (fx*  <fix>      0) => 0
  98. ;;;  (fx*      0  <fix>) => 0
  99. ;;;  (fx*  <fix>      1) => <fix>
  100. ;;;  (fx*      1  <fix>) => <fix>
  101. ;;;  (fx* <2**N>  <fix>) => (fixnum-ashl <fix> N)
  102. ;;;  (fx*  <fix> <2**N>) => (fixnum-ashl <fix> N)
  103.  
  104. ;;;  (fx* <small fix> <fix>) => shift and add <fix>
  105.  
  106. (define (simplify-fixnum-multiply call)
  107.   (let* ((n1 ((call-arg 2) call))
  108.          (n2 ((call-arg 3) call))
  109.          (a1 (fixnum-value n1))
  110.          (a2 (fixnum-value n2)))
  111.     (cond ((fixnum-constant-fold call a1 a2 fixnum-multiply)
  112.            t)
  113.           (a1
  114.            (or (reduce-arith-identity call a1 n2 1)
  115.                (reduce-arith-no-op call (fx= a1 0) 0)
  116.                (reduce-multiply-by-2**n call a1 'fixnum-ashl n2)))
  117.           (a2
  118.            (or (reduce-arith-identity call a2 n1 1)
  119.                (reduce-arith-no-op call (fx= a2 0) 0)
  120.                (reduce-multiply-by-2**n call a2 'fixnum-ashl n1)))
  121.           (else nil))))
  122.  
  123. ;;;  (fx/ <fix>  <fix>) => 1   NO! <fix> may be 0
  124. ;;;  (fx/ <fix>      1) => <fix>
  125. ;;;  (fx/     0  <fix>) => 0 
  126. ;;;  (fx/ <fix>      0) => error
  127. ;;;  (fx/ <fix> <2**N>) => (fixnum-ashr <fix> N)
  128.  
  129. (define (simplify-fixnum-divide call)
  130.   (let* ((n1 ((call-arg 2) call))
  131.          (n2 ((call-arg 3) call))
  132.          (a1 (fixnum-value n1))
  133.          (a2 (fixnum-value n2)))
  134.     (cond ((and a2 (eq? a2 0))                ; Must check first
  135.            (fix-user-error call "fixnum divide by 0")
  136.            t)
  137.           ((fixnum-constant-fold call a1 a2 fixnum-divide)
  138.            t)
  139.           (a1
  140.            (reduce-arith-no-op call (fx= a1 0) 0))
  141.           (a2
  142.            (or (reduce-arith-identity call a2 n1 1)
  143.                (reduce-multiply-by-2**n call a2 'fixnum-ashr n1)))
  144.           (else nil))))
  145.                                       
  146. ;;; (<op> <arg> 2**n) => (<proc> <arg> n)
  147.  
  148. (define (reduce-multiply-by-2**n call arg proc node)
  149.   (cond ((fixnum-power-of-two? arg)
  150.          (replace-call call
  151.                        proc
  152.                        (detach node)
  153.                        (create-literal-node (fx- (fixnum-howlong arg) 1)))
  154.          t)
  155.         (else nil)))
  156.  
  157. (define (fixnum-power-of-two? x)
  158.   (and (fx> x 1)
  159.        (fx= x (fixnum-ashl 1 (fx- (fixnum-howlong x) 1)))))
  160.  
  161. (define (obtain-system-primop name)                                      
  162.   (let* ((v (get-system-variable name))
  163.          (p (if v (definition->primop (variable-definition v)) nil)))
  164.     (if p p (bug '"can't find system primop ~S" name))))
  165.  
  166. (define (replace-call call proc-name . args)
  167.   (let ((new (create-call-node (fx+ '2 (length args)) '1))
  168.         (var (get-system-variable proc-name)))
  169.     (relate call-proc new (create-reference-node var))
  170.     (relate-call-args new (cons (detach ((call-arg '1) call)) args))
  171.     (replace call new)
  172.     t))
  173.  
  174. ;;;  (fx-ior <fix>     0) => <fix>
  175. ;;;  (fx-ior <fix>    -1) => -1
  176. ;;;  (fx-ior     0 <fix>) => <fix>
  177. ;;;  (fx-ior    -1 <fix>) => -1
  178. ;;;  (fx-ior <fix> <fix>) => <fix>
  179.  
  180. (define (simplify-fixnum-logior call)
  181.   (let* ((n1 ((call-arg 2) call))
  182.          (n2 ((call-arg 3) call))
  183.          (a1 (fixnum-value n1))
  184.          (a2 (fixnum-value n2)))
  185.     (cond ((fixnum-constant-fold call a1 a2 fixnum-logior)
  186.            t)
  187.           (a1
  188.            (or (reduce-arith-identity call a1 n2 0)
  189.                (reduce-arith-no-op call (fx= a1 -1) -1)))
  190.           (a2
  191.            (or (reduce-arith-identity call a2 n1 0)
  192.                (reduce-arith-no-op call (fx= a2 -1) -1)))
  193.           ((duplicate-args? n1 n2)
  194.            (replace-call-with-value call (detach n1)))
  195.           (else nil))))
  196.  
  197. ;;;  (fx-xor <fix>     0) => <fix>
  198. ;;;  (fx-xor 0     <fix>) => <fix>
  199. ;;;  (fx-xor <fix> <fix>) => 0
  200.  
  201. (define (simplify-fixnum-logxor call)
  202.   (let* ((n1 ((call-arg 2) call))
  203.          (n2 ((call-arg 3) call))
  204.          (a1 (fixnum-value n1))
  205.          (a2 (fixnum-value n2)))
  206.     (cond ((fixnum-constant-fold call a1 a2 fixnum-logxor)
  207.            t)
  208.           (a1
  209.            (reduce-arith-identity call a1 n2 0))
  210.           (a2
  211.            (reduce-arith-identity call a2 n1 0))
  212.           ((duplicate-args? n1 n2)
  213.            (replace-call-with-value call (create-literal-node 0)))
  214.           (else nil))))
  215.  
  216. ;;;  (fx-and <fix>     0) => 0
  217. ;;;  (fx-and <fix>    -1) => <fix>
  218. ;;;  (fx-and     0 <fix>) => 0
  219. ;;;  (fx-and    -1 <fix>) => <fix>
  220. ;;;  (fx-and <fix> <fix>) => <fix>
  221.  
  222. (define (simplify-fixnum-logand call)
  223.   (let* ((n1 ((call-arg 2) call))
  224.          (n2 ((call-arg 3) call))
  225.          (a1 (fixnum-value n1))
  226.          (a2 (fixnum-value n2)))
  227.     (cond ((fixnum-constant-fold call a1 a2 fixnum-logand)
  228.            t)
  229.           (a1
  230.            (or (reduce-arith-identity call a1 n2 -1)
  231.                (reduce-arith-no-op call (fx= a1 0) 0)))
  232.           (a2
  233.            (or (reduce-arith-identity call a2 n1 -1)
  234.                (reduce-arith-no-op call (fx= a2 0) 0)))
  235.           ((duplicate-args? n1 n2)
  236.            (replace-call-with-value call (detach n1)))
  237.           (else nil))))
  238.  
  239. ;;;  (fx-ash~ <fix>      0) => <fix>
  240. ;;;  (fx-ash~ 0      <fix>) => 0
  241. ;;;  (fx-ash~ <fix> *>=30*) => 0
  242.  
  243. (define (simplify-fixnum-shift call op)
  244.   (let* ((n1 ((call-arg 2) call))
  245.          (n2 ((call-arg 3) call))
  246.          (a1 (fixnum-value n1))
  247.          (a2 (fixnum-value n2)))
  248.     (cond ((fixnum-constant-fold call a1 a2 op)
  249.            t)
  250.           (a1
  251.            (reduce-arith-no-op call (fx= a1 0) 0))
  252.           (a2
  253.            (or (reduce-arith-identity call a2 n1 0)
  254.                (reduce-arith-no-op call (fx>= a2 *bits-per-fixnum*) 0)))
  255.           (else nil))))
  256.  
  257.