home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / machines / spectrum / lapopt.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  12.2 KB  |  449 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: lapopt.scm,v 1.15 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1991-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; LAP Optimizer for HP Precision Archtecture.
  23. ;; package: (compiler lap-optimizer)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; An instruction classifier and decomposer
  28.  
  29. (define-integrable (float-reg reg)
  30.   (+ 32 reg))
  31.  
  32. (define (classify-instruction instr)
  33.   ;; (values type target source-1 source-2 offset)
  34.   ;; This needs the following:
  35.   ;; - Loads with base modification (LDWM)
  36.   ;; - Third source (indexed loads)
  37.   (let ((opcode (car instr)))
  38.     (cond ((memq opcode '(ANDCM AND OR XOR UXOR SUB DS SUBT
  39.                 SUBB ADD SH1ADD SH2ADD SH3ADD ADDC
  40.                 COMCLR UADDCM UADDCMT ADDL SH1ADDL
  41.                 SH2ADDL SH3ADDL SUBO SUBTO SUBBO
  42.                 ADDO SH1ADDO SH2ADDO SH3ADDO ADDCO
  43.                 VSHD SHD))
  44.        ;; source source ... target
  45.        (values 'ALU
  46.            ;; not (list-ref instr 4)
  47.            (car (last-pair instr))
  48.            (list-ref instr 2)
  49.            (list-ref instr 3)
  50.            false))
  51.       ((memq opcode '(ADDI ADDIO ADDIT ADDITO SUBI SUBIO COMICLR))
  52.        ;; immed source target
  53.        (values 'ALU
  54.            (list-ref instr 4)
  55.            (list-ref instr 3)
  56.            false
  57.            false))
  58.       ((memq opcode '(COPY))
  59.        ;; source target
  60.        (values 'ALU
  61.            (list-ref instr 3)
  62.            (list-ref instr 2)
  63.            false
  64.            false))
  65.       ((memq opcode '(LDW LDB LDO LDH))
  66.        ;; (offset n m source) target
  67.        (let ((offset (list-ref instr 2)))
  68.          (values 'MEMORY
  69.              (list-ref instr 3)
  70.              (cadddr offset)
  71.              false
  72.              (cadr offset))))
  73.       ((memq opcode '(STW STB STH))
  74.        ;; source1 (offset n m source2)
  75.        (let ((offset (list-ref instr 3)))
  76.          (values 'MEMORY
  77.              false
  78.              (list-ref instr 2)
  79.              (cadddr offset)
  80.              (cadr offset))))
  81.       ((memq opcode '(STWM STWS))
  82.        ;; source1 (offset n m target/source)
  83.        (let* ((offset (list-ref instr 3))
  84.           (base (cadddr offset)))
  85.          (values 'MEMORY
  86.              base
  87.              (list-ref instr 2)
  88.              base
  89.              (cadr offset))))
  90.  
  91.       ((memq opcode '(LDI LDIL))
  92.        ;; immed target
  93.        (values 'ALU
  94.            (list-ref instr 3)
  95.            false
  96.            false
  97.            false))
  98.       ((memq opcode '(ADDIL))
  99.        ;; immed source
  100.        (values 'ALU
  101.            regnum:addil-result
  102.            (list-ref instr 3)
  103.            false
  104.            false))
  105.       ((memq opcode '(NOP))
  106.        (values 'ALU false false false false))
  107.       ((memq opcode '(VDEPI DEPI ZVDEPI ZDEPI))
  108.        (values 'ALU
  109.            (car (last-pair instr))
  110.            false
  111.            false
  112.            false))
  113.       ((memq opcode '(EXTRU EXTRS DEP ZDEP))
  114.        (values 'ALU
  115.            (list-ref instr 5)
  116.            (list-ref instr 2)
  117.            false
  118.            false))
  119.       ((memq opcode '(VEXTRU VEXTRS VDEP ZVDEP))
  120.        (values 'ALU
  121.            (list-ref instr 4)
  122.            (list-ref instr 2)
  123.            false
  124.            false))
  125.       ((memq opcode '(FCPY FABS FSQRT FRND))
  126.        ;; source target
  127.        (values 'FALU
  128.            (float-reg (list-ref instr 3))
  129.            (float-reg (list-ref instr 2))
  130.            false
  131.            false))
  132.       ((memq opcode '(FADD FSUB FMPY FDIV FREM))
  133.        ;; source1 source2 target
  134.        (values 'FALU
  135.            (float-reg (list-ref instr 4))
  136.            (float-reg (list-ref instr 2))
  137.            (float-reg (list-ref instr 3))
  138.            false))
  139.       ((eq? opcode 'FSTDS)
  140.        ;; source (offset n m base)
  141.        (let* ((offset (list-ref instr 3))
  142.           (base (cadddr offset)))
  143.          (values 'MEMORY
  144.              (and (or (memq 'MA (cadr instr))
  145.                   (memq 'MB (cadr instr)))
  146.               base)
  147.              base
  148.              (float-reg (list-ref instr 2))
  149.              (cadr offset))))
  150.  
  151.       #|
  152.       ((memq opcode '(B BL GATE))
  153.        <>)
  154.       ((memq opcode '(BV BLR))
  155.        ;; source-1 source-2
  156.        (values 'CONTROL
  157.            false
  158.            (list-ref instr 2)
  159.            (list-ref instr 3)
  160.            false))
  161.       ((memq opcode '(BLR))
  162.        ;; source target
  163.        (values 'CONTROL
  164.            (list-ref instr 3)
  165.            (list-ref instr 2)
  166.            false
  167.            false))
  168.       ((memq opcode '(BV))
  169.        ;; source-1 source-2
  170.        (values 'CONTROL
  171.            false
  172.            (list-ref instr 2)
  173.            (list-ref instr 3)
  174.            false))
  175.       ((memq opcode '(BE))
  176.        <>)
  177.       ((memq opcode '(BLE))
  178.        <>)
  179.       ((memq opcode '(COMB ...))
  180.        <>)
  181.       ((memq opcode '(PCR-HOOK))
  182.        <>)
  183.       ((memq opcode '(LABEL EQUATE ENTRY-POINT
  184.                 EXTERNAL-LABEL BLOCK-OFFSET
  185.                 SCHEME-OBJECT SCHEME-EVALUATION PADDING))
  186.        (values 'DIRECTIVE false false false false))
  187.       |#
  188.       (else
  189.        (values 'UNKNOWN false false false false)))))
  190.  
  191. (define (offset-fits? offset opcode)
  192.   (and (number? offset)
  193.        (memq opcode '(LDW LDB LDO LDH STW STB STH STWM LDWM
  194.               STWS LDWS FLDWS FLDDS FSTWS FSTDS))
  195.        (<= -8192 offset 8191)))
  196.  
  197. ;;;; Utilities
  198.  
  199. ;; A trivial pattern matcher
  200.  
  201. (define (match pattern instance)
  202.   (let ((dict '(("empty" . empty))))
  203.  
  204.     (define (match-internal pattern instance)
  205.       (cond ((not (pair? pattern))
  206.          (eqv? pattern instance))
  207.         ((eq? (car pattern) '?)
  208.          (let ((var (cadr pattern))
  209.            (val instance))
  210.            (cond ((eq? var '?)    ; quoting ?
  211.               (eq? val '?))
  212.              ((assq var dict)
  213.               => (lambda (place)
  214.                (equal? (cdr place) val)))
  215.              (else
  216.               (set! dict (cons (cons var val) dict))
  217.               true))))
  218.         (else
  219.          (and (pair? instance)
  220.           (match-internal (car pattern) (car instance))
  221.           (match-internal (cdr pattern) (cdr instance))))))
  222.  
  223.     (and (match-internal pattern instance)
  224.      dict)))
  225.  
  226. (define (pc-sensitive? instr)
  227.   (or (eq? instr '*PC*)
  228.       (and (pair? instr)
  229.        (or (pc-sensitive? (car instr))
  230.            (pc-sensitive? (cdr instr))))))
  231.  
  232. (define (skips? instr)
  233.   ;; Not really true, for example
  234.   ;; (COMBT (<) ...)
  235.   (and (pair? (cadr instr))
  236.        (not (memq (car instr)
  237.           '(B BL BV BLR BLE BE
  238.               LDWS LDHS LDBS LDCWS
  239.               STWS STHS STBS STBYS
  240.               FLDWS FLDDS FSTWS FSTDS)))
  241.        ;; or SGL, or QUAD, but not used now.
  242.        (not (memq 'DBL (cadr instr)))))
  243.  
  244. (define (find-or-label instrs)
  245.   (and (not (null? instrs))
  246.        (if (memq (caar instrs)
  247.          '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
  248.        (find-or-label (cdr instrs))
  249.        instrs)))
  250.  
  251. (define (find-non-label instrs)
  252.   (and (not (null? instrs))
  253.        (if (memq (caar instrs)
  254.          '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
  255.        (find-non-label (cdr instrs))
  256.        instrs)))
  257.  
  258. (define (list-difference whole suffix)
  259.   (if (eq? whole suffix)
  260.       '()
  261.       (cons (car whole)
  262.         (list-difference (cdr whole) suffix))))
  263.  
  264. (define (fix-complex-return ret frame junk instr avoid)
  265.   (let ((syll `(OFFSET ,frame 0 ,regnum:stack-pointer)))
  266.     (if (and (eq? (car instr) 'STW)
  267.          (equal? (cadddr instr) syll))
  268.     ;; About to store return address.  Forego store completely
  269.     (let ((ret (caddr instr)))
  270.       `(,@(reverse junk)
  271.         (DEP () ,regnum:quad-bitmask
  272.          ,(-1+ scheme-type-width)
  273.          ,scheme-type-width
  274.          ,ret)
  275.         (BV () 0 ,ret)
  276.         (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
  277.          ,regnum:stack-pointer)))
  278.     (let ((ret (list-search-positive
  279.                (list ret regnum:first-arg regnum:second-arg
  280.                  regnum:third-arg regnum:fourth-arg)
  281.              (lambda (reg)
  282.                (not (memq reg avoid))))))
  283.       `(,@(reverse junk)
  284.         (LDW () ,syll ,ret)
  285.         ,instr
  286.         (DEP () ,regnum:quad-bitmask
  287.          ,(-1+ scheme-type-width)
  288.          ,scheme-type-width
  289.          ,ret)
  290.         (BV () 0 ,ret)
  291.         (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
  292.          ,regnum:stack-pointer))))))
  293.  
  294. (define (fix-simple-return ret frame junk)
  295.   `(,@(reverse junk)
  296.     (LDW () (OFFSET ,frame 0 ,regnum:stack-pointer) ,ret)
  297.     (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
  298.      ,regnum:stack-pointer)
  299.     (DEP () ,regnum:quad-bitmask
  300.      ,(-1+ scheme-type-width)
  301.      ,scheme-type-width
  302.      ,ret)
  303.     (BV (N) 0 ,ret)))
  304.  
  305. (define (fix-a-return dict1 junk dict2 rest)
  306.   (let* ((next (find-or-label rest))
  307.      (next* (and next (find-non-label next)))
  308.      (frame (cdr (assq 'frame dict2)))
  309.      (ret (cdr (assq 'ret dict1))))
  310.     (cond ((or (not next)
  311.            (pc-sensitive? (car next))
  312.            (memq (caar next)
  313.              '(ENTRY-POINT EXTERNAL-LABEL BLOCK-OFFSET PCR-HOOK))
  314.            (and (eq? (caar next) 'LABEL)
  315.             (or (not next*)
  316.             (not (skips? (car next*))))))
  317.        (values (fix-simple-return ret frame junk)
  318.            rest))
  319.       ((or (eq? (caar next) 'LABEL)
  320.            (skips? (car next)))
  321.        (values '() false))
  322.       (else
  323.        (with-values
  324.            (lambda () (classify-instruction (car next)))
  325.          (lambda (type target src1 src2 offset)
  326.            offset            ; ignored
  327.            (if (or (not (memq type '(MEMORY ALU FALU)))
  328.                (eq? target regnum:stack-pointer))
  329.            (values (fix-simple-return ret frame junk)
  330.                rest)
  331.            (values
  332.             (fix-complex-return ret frame
  333.                     (append junk
  334.                         (list-difference rest next))
  335.                     (car next)
  336.                     (list target src1 src2))
  337.             (cdr next)))))))))
  338.  
  339. (define (fix-sequences instrs tail)
  340.   (define-integrable (fail)
  341.     (fix-sequences (cdr instrs)
  342.            (cons (car instrs) tail)))
  343.  
  344.   (if (null? instrs)
  345.       tail
  346.       (let* ((instr (car instrs))
  347.          (opcode (car instr)))
  348.     (case opcode
  349.       ((BV)
  350.        (let ((dict1 (match (cdr return-pattern) instrs)))
  351.          (if (not dict1)
  352.          (fail)
  353.          (let* ((tail* (cdddr instrs))
  354.             (next (find-or-label tail*))
  355.             (fail*
  356.              (lambda ()
  357.                (fix-sequences
  358.                 tail*
  359.                 (append (reverse (list-head instrs 3))
  360.                     tail))))
  361.             (dict2
  362.              (and next
  363.                   (match (car return-pattern) (car next)))))
  364.                  
  365.            (if (not dict2)
  366.                (fail*)
  367.                (with-values
  368.                (lambda ()
  369.                  (fix-a-return dict1
  370.                        (list-difference tail* next)
  371.                        dict2
  372.                        (cdr next)))
  373.              (lambda (frobbed untouched)
  374.                (if (null? frobbed)
  375.                    (fail*)
  376.                    (fix-sequences untouched
  377.                           (append frobbed tail))))))))))
  378.       ((B BE BLE)
  379.        (let ((completer (cadr instr)))
  380.          (if (or (not (pair? completer))
  381.              (not (eq? 'N (car completer)))
  382.              (not (null? (cdr completer))))
  383.          (fail)
  384.          (with-values (lambda () (find-movable-instr (cdr instrs)))
  385.            (lambda (movable junk rest)
  386.              (if (not movable)
  387.              (fail)
  388.              (fix-sequences
  389.               rest
  390.               `(,@(reverse junk)
  391.                 (,opcode () ,@(cddr instr))
  392.                 ,movable
  393.                 ,@tail))))))))
  394.  
  395.       ((NOP)
  396.        (let ((dict (match hook-pattern instrs)))
  397.          (if (not dict)
  398.          (fail)
  399.          (with-values (lambda () (find-movable-instr (cddr instrs)))
  400.            (lambda (movable junk rest)
  401.              (if (not movable)
  402.              (fail)
  403.              (fix-sequences
  404.               rest
  405.               `(,@(reverse junk)
  406.                 ,(cadr instrs)
  407.                 ,movable
  408.                 ,@tail))))))))
  409.       (else
  410.        (fail))))))
  411.  
  412. (define (find-movable-instr instrs)
  413.   (let* ((next (find-or-label instrs))
  414.      (instr (and next (car next)))
  415.      (next* (and next (find-non-label (cdr next)))))
  416.     (if (and instr
  417.          (with-values (lambda () (classify-instruction instr))
  418.            (lambda (type tgt src1 src2 offset)
  419.          tgt src1 src2        ; ignored
  420.          (or (memq type '(ALU FALU))
  421.              (and (eq? type 'MEMORY)
  422.               (offset-fits? offset (car instr))))))
  423.          (not (skips? instr))
  424.          (not (pc-sensitive? instr))
  425.          (or (not next*)
  426.          (not (skips? (car next*)))))
  427.     (values instr
  428.         (list-difference instrs next)
  429.         (cdr next))
  430.     (values false false false))))
  431.  
  432. (define return-pattern            ; reversed
  433.   (cons
  434.    `(LDO () (OFFSET (? frame) 0 ,regnum:stack-pointer) ,regnum:stack-pointer)
  435.    `((BV (N) 0 (? ret))
  436.      (DEP () ,regnum:quad-bitmask
  437.       ,(-1+ scheme-type-width)
  438.       ,scheme-type-width
  439.       (? ret))
  440.      (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) (? ret))
  441.      . (? more-insts))))
  442.  
  443. (define hook-pattern
  444.   `((NOP ())
  445.     (BLE () (OFFSET (? hook) 4 ,regnum:scheme-to-interface-ble))
  446.     . (? more-insts)))
  447.  
  448. (define (optimize-linear-lap instructions)
  449.   (fix-sequences (reverse! instructions) '()))