basis/call/call.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel kernel.private macros fry summary sequences
   4 sequences.private accessors effects effects.parser parser words
   5 make ;
   6 IN: call
   7
   8 ERROR: wrong-values effect ;
   9
  10 M: wrong-values summary drop "Quotation called with stack effect" ;
  11
  12 <PRIVATE
  13
  14 : parse-call( ( accum word -- accum )
  15     [ ")" parse-effect parsed ] dip parsed ;
  16
  17 : call-effect-unsafe ( quot effect -- )
  18     drop call ;
  19
  20 : call-unsafe( \ call-effect-unsafe parse-call( ; parsing
  21
  22 PRIVATE>
  23
  24 : (call-effect>quot) ( in out effect -- quot )
  25     [
  26         [ [ datastack ] dip dip ] %
  27         [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless ,
  28     ] [ ] make ;
  29
  30 : call-effect>quot ( effect -- quot )
  31     [ in>> length ] [ out>> length ] [ ] tri
  32     [ (call-effect>quot) ] keep add-effect-input
  33     [ call-effect-unsafe ] 2curry ;
  34
  35 MACRO: call-effect ( effect -- quot )
  36     call-effect>quot ;
  37
  38 : call( \ call-effect parse-call( ; parsing
  39
  40 <PRIVATE
  41
  42 : execute-effect-unsafe ( word effect -- )
  43     drop execute ;
  44
  45 : execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
  46
  47 : execute-effect-slow ( word effect -- )
  48     [ [ execute ] curry ] dip call-effect ; inline
  49
  50 : cache-hit? ( word ic -- ? ) first-unsafe eq? ; inline
  51
  52 : cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline
  53
  54 : execute-effect-unsafe? ( word effect -- ? )
  55     over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
  56
  57 : cache-miss ( word effect ic -- )
  58     2over execute-effect-unsafe?
  59     [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ]
  60     [ execute-effect-slow ] if ; inline
  61
  62 : execute-effect-ic ( word effect ic -- )
  63     #! ic is a mutable cell { effect }
  64     3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline
  65
  66 : execute-effect>quot ( effect -- quot )
  67     { f } clone [ execute-effect-ic ] 2curry ;
  68
  69 PRIVATE>
  70
  71 MACRO: execute-effect ( effect -- )
  72     execute-effect>quot ;
  73
  74 : execute( \ execute-effect parse-call( ; parsing