basis/compiler/cfg/builder/blocks/blocks.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays compiler.cfg compiler.cfg.instructions
   4 compiler.cfg.registers compiler.cfg.stacks.local
   5 compiler.cfg.utilities kernel make math namespaces sequences ;
   6 IN: compiler.cfg.builder.blocks
   7 SLOT: in-d
   8 SLOT: out-d
   9
  10 : set-basic-block ( basic-block -- )
  11     dup begin-local-analysis instructions>> building set ;
  12
  13 : end-basic-block ( block -- )
  14     end-local-analysis building off ;
  15
  16 : (begin-basic-block) ( block -- block' )
  17     <basic-block> dup set-basic-block [ connect-bbs ] keep ;
  18
  19 : begin-basic-block ( block -- block' )
  20     dup end-basic-block (begin-basic-block) ;
  21
  22 : emit-trivial-block ( block quot: ( ..a block' -- ..b ) -- block' )
  23     ##branch, swap begin-basic-block
  24     [ swap call ] keep
  25     ##branch, begin-basic-block ; inline
  26
  27 : call-height ( #call -- n )
  28     [ out-d>> length ] [ in-d>> length ] bi - ;
  29
  30 : emit-call-block ( word height block -- )
  31     t swap kill-block?<<
  32     <ds-loc> inc-stack ##call, ;
  33
  34 : emit-trivial-call ( block word height -- block' )
  35     rot [ emit-call-block ] emit-trivial-block ;
  36
  37 : emit-primitive ( block #call -- block' )
  38     [ word>> ] [ call-height ] bi emit-trivial-call ;
  39
  40 : begin-branch ( block -- block' )
  41     height-state [ clone ] change (begin-basic-block) ;
  42
  43 : end-branch ( block/f -- pair/f )
  44     dup [
  45         ##branch,
  46         end-local-analysis
  47         height-state get clone 2array
  48     ] when* ;
  49
  50 : with-branch ( block quot: ( ..a block -- ..b block' ) -- pair/f )
  51     [ [ begin-branch ] dip call end-branch ] with-scope ; inline
  52
  53 : emit-conditional ( block branches -- block'/f )
  54     swap end-basic-block
  55     sift [ f ] [
  56         dup first second height-state set
  57         [ first ] map
  58         <basic-block> dup set-basic-block
  59         [ connect-Nto1-bbs ] keep
  60     ] if-empty ;