level1/70_compiler_20_opt_basic.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 UROPT_DEBUG_ALIAS equ 0
   8 UROPT_DEBUG_BROPT equ 0
   9
  10 vocabulary OPTIMISER
  11 voc-set-active OPTIMISER
  12
  13
  14 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15 ;; replace alias call with referred address
  16 : optimise-alias-call  ( cfa -- true // cfa false )
  17   begin
  18     ;; check for jmp
  19     dup c@ 0xe9 = ifnot false exit endif
  20       \ endcr ." ALIAS?: " dup cfa-wsize . cr
  21     ;; should be exactly 5/8 bytes
  22     dup cfa-wsize (#cfa) = ifnot false exit endif
  23     $if UROPT_DEBUG_ALIAS
  24       endcr ." ALIAS: " dup cfa->nfa id. ."  -> " dup 1+ compiler:(disp32@) cfa->nfa id. cr
  25     $endif
  26     ;; get new cfa address, and check if it is an alias too
  27     1+ compiler:(disp32@)
  28   again
  29 ;
  30
  31
  32 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;; branch stack contands addresses of branch instructions
  34 ;; end of block is 0
  35
  36 256 constant #jstack
  37 #jstack cells buffer: jstack
  38 -1 value jsp
  39
  40 : jpush  ( n -- )
  41   jsp dup -if 2drop
  42   else dup #jstack < if dup 1+ to jsp jstack cells^ !
  43   else 2drop -1 to jsp  ;; overflow
  44     endcr ." WARNING: branch optimiser stack overflow in \`" latest-nfa id. ." \`\n"
  45   endif endif
  46 ;
  47
  48 : jpop  ( -- n // 0 )
  49   jsp 1- dup -if drop 0
  50   else dup to jsp jstack cells^ @ endif
  51 ;
  52
  53 : jpush-branch  ( -- )  here [execute-tail] jpush ;
  54
  55 : jstack-reset  ( -- )  -1 to jsp ;
  56 : jstack-init  ( -- )  forth:(opt-branches?) if 0 else -1 endif to jsp ;
  57 : jstack-subinit  ( -- )  forth:(opt-branches?) if jsp 0 max to jsp 0 jpush endif ;
  58
  59 : jstack-pop-frame  ( -- )
  60   jsp +if begin jpop not-until else jstack-reset endif
  61 ;
  62
  63
  64 ;; type: 0 is unconditional branch; 1 is conditional branch
  65 ;; cfa: ( addr type -- stopcode )
  66 : jstack-foreach  ( cfa -- stopcode )
  67   jsp 1- dup -if drop false
  68   else
  69     0 swap do
  70       jstack i +cells @ ?dup ifnot break endif
  71       dup @ ['] branch <> rot dup >r execute
  72       ?dup if rdrop unloop exit endif
  73     r> -1 +loop drop false
  74   endif
  75 ;
  76
  77
  78 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  79 $if UROPT_DEBUG_BROPT
  80 false value (was-jump-fix)
  81 $endif
  82 false value (optimise-jumps-again)
  83
  84 : optimise-jumps  ( -- )
  85   jsp +if
  86     begin
  87       false to (optimise-jumps-again)
  88       [:  ( addr type -- stopflag )
  89         ifnot
  90           $if UROPT_DEBUG_BROPT
  91             false to (was-jump-fix)
  92             \ endcr ." ***[ " latest-nfa id. ."  ]***\n"
  93           $endif
  94           [:  ( addr braddr type -- addr stopflag )
  95             >r 2dup cell+ @ = if  ;; braddr jumps to addr, reroute it
  96               $if UROPT_DEBUG_BROPT
  97                 (was-jump-fix) ifnot endcr ." === processing JUMP at 0x" over .hex8 ."  <" latest-nfa id. ." > ===\n" true to (was-jump-fix) endif
  98                 endcr ."   fixing " r@ if ." X" else space endif ." BRN at 0x" dup .hex8 cr
  99               $endif
 100               cell+ over cell+ @  2dup swap @ <> if  ( addr braddr+4 [addr+4] )
 101                 swap !  true to (optimise-jumps-again)
 102               else 2drop endif
 103             else drop endif
 104             rdrop false
 105           ;] jstack-foreach 2drop
 106         else drop endif
 107         false
 108       ;] jstack-foreach drop
 109     (optimise-jumps-again) not-until
 110     jstack-pop-frame
 111   else jstack-reset endif
 112 ;
 113
 114
 115 voc-set-active FORTH