PreviousUpNext

15.4.1478  src/lib/x-kit/xclient/pkg/window/pen-to-gcontext-imp.pkg

## pen-to-gcontext-imp.pkg
#
# The graphics context cache imp, which maps
# the immutable pens we present to the
# Mythryl programmer onto the the mutable
# graphics contexts provided by the X-server.
#
# Nomenclature:
#   Throughout this file, "gc" == "graphics context".
#
# The basic idea is that we have a relatively large
# number of client-side immutable "pens" -- see
#     src/lib/x-kit/xclient/pkg/window/pen.pkg
#     src/lib/x-kit/xclient/pkg/window/pen-guts.api
#     src/lib/x-kit/xclient/pkg/window/pen-guts.pkg
# -- which must be mapped to a smaller number of
# mutable gcs on the X server.  (Working with immutable
# pens simplifies the programmer's model by eliminating
# the shared mutable state of the gcs from it.)
#
# A given X drawing operation uses only a subset of the
# traits of a pen/gc, so we can assign to that draw op's
# pen any gc matching on the traits actually used.
#
# We manage this by treating our set of gcs as a
# cache, tracking the hit ratio to manage cache
# size, and reassigning the least-recently-used
# gc when no match to a pen can be found.
#
# For speed, we track pen and gc traits as bitmaps
# and search for matches using bitmap operations.
#
# This package gets used by:
#     src/lib/x-kit/xclient/pkg/window/xsession.pkg
#     src/lib/x-kit/xclient/pkg/window/draw-imp.pkg
#
# Our allocate* and free* functions are however called
# only from the latter; we are essentially supporting
# infrastructure for draw-imp.
#
# The system will have only one pen_to_gcontext_imp,
# but it may be used by many draw_imp clients.  (This
# is forced by the the X architecture's requirement that
# each graphics context etc may be used only on one visual;
# currently we anyhow allocate a separate draw_imp for every
# toplevel window.)
#
# Consquently we must deal with resource contention between
# multiple draw_imp instances concurrently trying to use gcs.
#
# We handle this by having draw_imps explicitly allocate and
# free the gcs they use.  This is reasonably reliable because
# it happens only in draw_batch() in the pattern
#     
#   {   gc =   alloc_gc { pen, used => mask };
#       draw_ops (gc, xid0) ops;
#       free_gc gc;
#   };
#     
# We then maintain in each In_Use_Gc record an explicit
# 'refcount' field counting the number of draw_imp clients
# which currently have that gc allocated;  we cannot
# rewrite fields in such a gc until the refcount returns
# to zero.

# Compiled by:
#     src/lib/x-kit/xclient/xclient-internals.sublib


# TODO:
#  support fonts        XXX BUGGO FIXME



###           "Men who say it cannot be done should not
###            interrupt those who are doing it."
###
###                            -- Chinsese proverb



stipulate
    include threadkit;                                                  # threadkit                     is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    #
    package dy  =  display;                                             # display                       is from   src/lib/x-kit/xclient/pkg/wire/display.pkg
    package xg  =  xgeometry;                                           # xgeometry                     is from   src/lib/std/2d/xgeometry.pkg
    package xt  =  xtypes;                                              # xtypes                        is from   src/lib/x-kit/xclient/pkg/wire/xtypes.pkg
    package pg  =  pen_guts;                                            # pen_guts                      is from   src/lib/x-kit/xclient/pkg/window/pen-guts.pkg
    package v2w =  value_to_wire;                                       # value_to_wire                 is from   src/lib/x-kit/xclient/pkg/wire/value-to-wire.pkg
    package xok =  xsocket;                                             # xsocket                       is from   src/lib/x-kit/xclient/pkg/wire/xsocket.pkg
    package t2s =  xtype_to_string;                                     # xtype_to_string               is from   src/lib/x-kit/xclient/pkg/to-string/xtype-to-string.pkg
    package xtr =  xlogger;                                             # xlogger                       is from   src/lib/x-kit/xclient/pkg/stuff/xlogger.pkg
    #
    trace =  xlogger::log_if xlogger::graphics_context_logging; # Conditionally write strings to tracing.log or whatever.
herein


    package   pen_to_gcontext_imp
    : (weak)  Pen_To_Gcontext_Imp                                       # Pen_To_Gcontext_Imp   is from   src/lib/x-kit/xclient/pkg/window/pen-to-gcontext-imp.api
    {

        stipulate


            xid_to_string =  t2s::xid_to_string;

            gc_slot_count = 23;
            font_gcslot   = 14;                                         # The slot in a GC for the font.

            clip_origin_penslot = 14;                                   # The slot in a pen for the clip origin.
            clip_mask_penslot   = 15;                                   # The slot in a pen for the clip mask.
            dash_offset_penslot = 16;                                   # The slot in a pen for the dash offset.
            dashlist_penslot    = 17;                                   # The slot in a pen for the dash list.

            # GC request/reply messages.                                # "GC" == "graphics context" throughout this file.
            #
            # There are two basic requests: acquire and release a GC.
            # When acquiring a GC, one supplies a pen
            # and bit-vector telling which fields are
            # used by the drawing operation.
            #
            # For text drawing, there are two
            # forms of acquire request:
            #
            #     ACQUIRE_GC_WITH_FONT specifies that
            #         the font field is needed; the reply will be
            #         REPLY_GC_WITH_FONT and will specify the
            #         current value of the GC's font.  It is the
            #         drawing operation's (presumably a DrawText)
            #         responsibility to restore the font.
            #
            #     ACQUIRE_GC_AND_SET_FONT request requires
            #         that the GC have the requested font and
            #         will generate a normal REPLY_GC reply.
            #
            Plea_Mail
              #
              = ACQUIRE_GC               { pen: pg::Pen,   used: Unt                     }
              | ACQUIRE_GC_WITH_FONT     { pen: pg::Pen,   used: Unt,   fid: xt::Font_Id }
              | ACQUIRE_GC_AND_SET_FONT  { pen: pg::Pen,   used: Unt,   fid: xt::Font_Id }
              #
              | RELEASE_GC           xt::Graphics_Context_Id
              | RELEASE_GC_AND_FONT  xt::Graphics_Context_Id
              ;

            Reply_Mail
              #
              = REPLY_GC             xt::Graphics_Context_Id
              | REPLY_GC_WITH_FONT  (xt::Graphics_Context_Id, xt::Font_Id)
              ;

            # A given graphics context may have
            # no associated font.  If it does have
            # an associated font, that font may be
            # in use or unused:
            #
            Font_Status
              #
              = NO_FONT                                 # No font has been set yet in this GC.
              | UNUSED_FONT  xt::Font_Id                # There is a font set, but it is not currently being used. 
              | IN_USE_FONT (xt::Font_Id, Int)          # In-use font plus current number of users.
              ;

            Free_Gc
              =
              FREE_GC
                { gc_id: xt::Graphics_Context_Id,       # 29-bit integer X id for X-server graphics context.
                  desc:  pg::Pen,                       # A descriptor of the values of the GC.
                  font:  Font_Status                    # The current font (if any).
                };

            In_Use_Gc
              =
              IN_USE_GC
                { gc_id: xt::Graphics_Context_Id,       # 29-bit integer X id for X-server graphics context.
                  desc:  pg::Pen,                       # A descriptor of the values of the GC.
                  font:  Ref( Font_Status ),            # The current font (if any).
                  used:  Ref( Unt ),                    # A bit-mask telling which components of the GC are being used.
                  refcount:  Ref( Int )                 # The number of draw_imp clients using the GC, including those using the font. 
                };

            #  +DEBUG 

            fun font_sts2s (NO_FONT)          =>  "NoFont";
                font_sts2s (UNUSED_FONT f)    =>  string::cat ["UNUSED_FONT(", xid_to_string f, ")"];
                font_sts2s (IN_USE_FONT (f, n)) =>  string::cat [ "IN_USE_FONT(", xid_to_string f, ", ", int::to_string n, ")" ];
            end;

            fun in_use_gc_to_string (IN_USE_GC { gc_id, desc, font, used, refcount } )
                =
                string::cat
                  [
                    "IN_USE_GC { gc_id=", xid_to_string gc_id, ", font=", font_sts2s *font,
                    ", refcount=", int::to_string *refcount, "}"
                  ];

            #  -DEBUG 

            (|)  = unt::bitwise_or;
            (&)  = unt::bitwise_and;
            (>>) = unt::(>>);
            (<<) = unt::(<<);

            infix val | & << >> ;

      /* +DEBUG 
            fun mask2str nbits m = number_string::padLeft '0' nbits (unt::fmt number_string::BIN m)
            penMask2str = mask2str PenRep::numPenSlots
            gcMask2str = mask2str numGCSlots
       -DEBUG */

            # Search a list of in-use GCs for
            # given gc_id and remove if free.
            #
            # We return NULL if gc did not become free,
            # otherwise the new FREE_GC plus the input
            # list with it removed:     
            #
            fun find_in_use_gc (our_gc_id, font_used, in_use_gcs)
                =
                find  in_use_gcs
                where
                    fun find []
                            =>
                            xgripe::impossible "[pen_to_gcontext_imp: lost in-use graphics context]";

                        find ((x as IN_USE_GC { gc_id, ... } ) ! rest)
                            =>
                            if (gc_id != our_gc_id)
                                #       
                                case (find rest)
                                    #
                                    THE (free_gcs, l) =>  THE (free_gcs, x ! l);
                                    NULL              =>  NULL;
                                esac;

                            else

                                case (font_used, x)
                                    #
                                    (FALSE, IN_USE_GC { refcount => REF 1, desc, font, ... })
                                        =>
                                        THE (FREE_GC { gc_id, desc, font => *font }, rest);             # Removing last reference makes GC free.

                                    (TRUE,  IN_USE_GC { refcount => REF 1, desc, font => REF (IN_USE_FONT (f, 1)), ... })
                                        =>
                                        THE (FREE_GC { gc_id, desc, font => UNUSED_FONT f }, rest);     # Ditto plus marking font as unused.

                                    (FALSE, IN_USE_GC { refcount as REF n, ... })
                                        =>
                                        {   refcount := n - 1;
                                            NULL;
                                        };

                                    (TRUE,  IN_USE_GC { refcount as REF n, font as REF (IN_USE_FONT (f, 1)), ... })
                                        =>
                                        {   refcount := n - 1;
                                            font := (UNUSED_FONT f);
                                            NULL;
                                        };

                                    (TRUE,  IN_USE_GC { refcount as REF n, font as REF (IN_USE_FONT (f, nf)), ... })
                                        =>
                                        {   refcount := n - 1;
                                            font := IN_USE_FONT (f, nf - 1);
                                            NULL;
                                        };

                                    (_, gc)
                                        =>
                                        xgripe::impossible (string::cat [
                                            "[Pen_Imp::findUsedGC: bogus in-use GC; font_used = ",
                                            bool::to_string font_used, ", gc = ", in_use_gc_to_string gc, "]"
                                        ]);
                                esac;
                            fi;
                    end;
                end;

            my (penslot_to_gcmask, penslot_to_gcslot)
                =
                {
                    l = [
                        [0],            #  pen-slot 0:  function 
                        [1],            #  pen-slot 1:  plane mask 
                        [2],            #  pen-slot 2:  foreground 
                        [3],            #  pen-slot 3:  background 
                        [4],            #  pen-slot 4:  line-width 
                        [5],            #  pen-slot 5:  line-style 
                        [6],            #  pen-slot 6:  cap-style 
                        [7],            #  pen-slot 7:  join-style 
                        [8],            #  pen-slot 8:  fill-style 
                        [9],            #  pen-slot 9:  fill-rule 
                        [10],           #  pen-slot 10: tile 
                        [11],           #  pen-slot 11: stipple 
                        [12, 13],       #  pen-slot 12: tile/stipple origin 
                        [15],           #  pen-slot 13: subwindow mode 
                        [17, 18],       #  pen-slot 14: clipping origin 
                        [19],           #  pen-slot 15: clipping mask 
                        [20],           #  pen-slot 16: dash offset 
                        [21],           #  pen-slot 17: dash list 
                        [22]            #  pen-slot 18: arc mode 
                      ];

                    # Convert  [12, 13] to an unt
                    # with bits 12, 13 set to 1, etc:
                    #
                    fun bitmask []      =>  0u0;
                        bitmask (i ! r) =>  (0u1 << unt::from_int i) | (bitmask r);
                    end;

                    (vector::from_list (map bitmask l), vector::from_list (map head l));
                };

            fun pen_mask_to_gcmask  pen_mask
                =
                loop (pen_mask, 0, 0u0)
                where 
                    fun loop (0u0, _, m)
                            =>
                            m;

                        loop (mask, i, m)
                            =>
                            (mask & 0u1)  == 0u0
                                ##
                                ??  loop (mask >> 0u1, i+1, m)
                                ::  loop (mask >> 0u1, i+1, m | vector::get (penslot_to_gcmask, i));
                    end;
                end;

        herein

            Pen_To_Gcontext_Imp
                =
                PEN_TO_GCONTEXT_IMP
                  {
                    plea_slot:  Mailslot( Plea_Mail  ),
                    reply_slot: Mailslot( Reply_Mail )
                  };

            # Create the graphics context imp
            # for the given screen:
            #
            fun make_pen_to_gcontext_imp (dy::XDISPLAY { xsocket, next_xid, ... }, drawable)
                =
                {   plea_slot  =   make_mailslot ();
                    reply_slot =   make_mailslot ();

                    min_hit_rate = 80;                          # We want at least 80% of GC requests to be matched.

                    fun hit_rate (hits, misses)
                        =
                        {   total = hits + misses;

                            if (total == 0)   100;
                            else              int::quot((100 * hits), total);
                            fi;
                        };

                    send_xrequest = xok::send_xrequest  xsocket;

                    # Map the values of a pen to an X-server
                    # GC initialization rw_vector.
                    #
                    # "dst_mask" specifies which values
                    # in the pen are to be mapped.
                    #
                    # Assume that all values are non-default:
                    # we copy fields from the screen's
                    # default GC for those.
                    #
                    fun pen_to_gcvals (pg::PEN { traits, ... }, dst_mask, font)
                        =
                        {   gc_vals = rw_vector::make_rw_vector (gc_slot_count, NULL);

                            fun update   (i, v) = rw_vector::set (gc_vals, i, THE (unt::from_int v));
                            fun update_u (i, v) = rw_vector::set (gc_vals, i, THE v);

                            fun init_val (i, pg::IS_WIRE v)
                                    =>
                                    update_u (vector::get (penslot_to_gcslot, i), v);

                                init_val (i, pg::IS_POINT (xg::POINT { col, row } ))
                                    =>
                                    {   j = vector::get (penslot_to_gcslot, i);

                                        update (j,   col);
                                        update (j+1, row);
                                    };

                                init_val (i, pg::IS_PIXMAP (xt::XID id))
                                    =>
                                    update_u (vector::get (penslot_to_gcslot, i), id);

                                init_val _
                                    =>
                                    ();
                            end;

                            fun init_vals (0u0, _)
                                    =>
                                    ();

                                init_vals (m, i)
                                    =>
                                    {   if ((m & 0u1) != 0u0)
                                            #
                                            init_val (i, vector::get (traits, i));
                                        fi;

                                        init_vals (m >> 0u1, i+1);
                                    };
                            end;

                            case font
                                #
                                THE (xt::XID fid) =>  update_u (font_gcslot, fid);
                                NULL              =>  ();
                            esac;

                            init_vals (dst_mask, 0);


                            { vals => xt::VALUE_LIST gc_vals,

                              clip_boxes
                                  =>
                                  if ((dst_mask & (0u1 << unt::from_int clip_mask_penslot)) == 0u0)
                                      # 
                                      NULL;
                                  else
                                      case (vector::get (traits, clip_mask_penslot))
                                          #
                                          pg::IS_BOXES boxes
                                              =>
                                              (THE (vector::get (traits, clip_origin_penslot), boxes));

                                          _ => NULL;
                                      esac;
                                  fi,

                              dashes => if ((dst_mask & (0u1 << unt::from_int dashlist_penslot)) == 0u0)
                                            #
                                            NULL;
                                        else
                                            case (vector::get (traits, dashlist_penslot))
                                                #
                                                 pg::IS_DASHES dashes
                                                     =>
                                                     THE (vector::get (traits, dash_offset_penslot), dashes);

                                                 _ => NULL;
                                            esac;
                                       fi
                              };
                        };                              # fun pen_to_gcvals 


                    fun set_dashes (_, NULL)
                            =>
                            ();

                        set_dashes (gc_id, THE (pg::IS_WIRE offset, dashes))
                            =>
                            send_xrequest (v2w::encode_set_dashes { gc_id, dashes, dash_offset => unt::to_int_x offset });

                        set_dashes (gc_id, THE(_, dashes))
                            =>
                            send_xrequest (v2w::encode_set_dashes { gc_id, dashes, dash_offset => 0 });
                    end;


                    fun set_clip_boxes (_, NULL)
                            =>
                            ();

                        set_clip_boxes (gc_id, THE (pg::IS_POINT pt, (order, boxes)))
                            =>
                            send_xrequest (v2w::encode_set_clip_boxes { gc_id, boxes, clip_origin => pt, ordering => order });

                        set_clip_boxes (gc_id, THE(_, (order, boxes)))
                            =>
                            send_xrequest (v2w::encode_set_clip_boxes { gc_id, clip_origin => xg::point::zero, ordering => order, boxes });
                    end;


                    # Set the font of a GC:
                    #
                    fun set_font (gc_id, xt::XID fid)
                        =
                        {   vals = rw_vector::make_rw_vector (gc_slot_count, NULL);

                            rw_vector::set (vals, font_gcslot, THE fid);

                            send_xrequest (v2w::encode_change_gc { gc_id, vals => xt::VALUE_LIST vals } );
                        };


                    # Create a new X-server GC.
                    # It is in-use by definition:
                    #
                    fun make_gc (pen as pg::PEN { bitmask, ... }, used_mask, font)
                        =
                        {   my { vals, dashes, clip_boxes }
                                =
                                pen_to_gcvals (pen, bitmask, font);

                            gc_id = next_xid();

                            send_xrequest (v2w::encode_create_gc { gc_id, drawable, vals } );

                            set_dashes (gc_id, dashes);
                            set_clip_boxes (gc_id, clip_boxes);

                            IN_USE_GC
                              { gc_id,
                                desc =>  pen,
                                #
                                font =>  REF case font    NULL => NO_FONT;  (THE f) => IN_USE_FONT (f, 1); esac,
                                used =>  REF used_mask,
                                #
                                refcount => REF 1
                              };
                          };

                    (make_gc (pg::default_pen, 0ux7FFFFF, NULL))
                        ->
                        default_gc as IN_USE_GC { gc_id => default_gcid, ... };

                    # Update an X-server GC so that
                    # it agrees with the given pen
                    # on the used values:
                    #
                    fun change_gc
                        (
                          FREE_GC { gc_id, font=>cur_font, ... },
                          pen as pg::PEN { bitmask, ... },
                          used_mask,
                          new_font
                        )
                        =
                        {   non_default_mask =  bitmask & used_mask;

                            default_mask = (unt::bitwise_not bitmask) & used_mask;

                            my (different_font, font)
                                =
                                case (cur_font, new_font)
                                    #
                                    (_,                  NULL) =>  (FALSE, NO_FONT);
                                    (NO_FONT,        THE fid ) =>  (TRUE, IN_USE_FONT (fid, 1));
                                    (UNUSED_FONT fid1, THE fid2) =>  ((fid1 != fid2), IN_USE_FONT (fid2, 1));
                                    (IN_USE_FONT _,           _) =>  xgripe::impossible "[Pen_Imp: used font in free_gcs gc]";
                                esac;

                            if (default_mask != 0u0)
                                #       
                                send_xrequest (
                                    v2w::encode_copy_gc
                                        {  from =>  default_gcid,
                                           to   =>  gc_id,
                                           mask =>  xt::VALUE_MASK (pen_mask_to_gcmask  default_mask)
                                        }
                                );
                            fi;

                            if (non_default_mask != 0u0
                            or  different_font)

                                (pen_to_gcvals (pen, bitmask, new_font))
                                    ->
                                    { vals, dashes, clip_boxes };

                                send_xrequest (v2w::encode_change_gc { gc_id, vals } );
                                set_dashes (gc_id, dashes);
                                set_clip_boxes (gc_id, clip_boxes);
                            fi;

                            IN_USE_GC
                              {
                                gc_id,
                                desc     =>  pen,
                                font     =>  REF font,
                                used     =>  REF used_mask,
                                refcount =>  REF 1
                              };
                        };


                    # Search a list of in-use GCs for
                    # one that matches the given pen:
                    #
                    fun match_in_use_gc (pen, used_mask, font, in_use_gcs)
                        =
                        f in_use_gcs
                        where

                            # NOTE: there may be used components in pen that are not used in arg, but that
                            # are defined differently.  We could still use arg, but we'll have to update it.
                            # The test for an approx. match would be:
                            #               if (pg::pen_match (m & used_mask, pen, desc)
                            #
                            match
                                =
                                case font
                                    #
                                    NULL
                                        =>
                                        (fn (IN_USE_GC { desc, ... } )
                                            =
                                            pg::pen_match (used_mask, pen, desc)
                                        );

                                    THE f
                                        =>
                                        match
                                        where
                                            fun match (IN_USE_GC { desc, font => REF (IN_USE_FONT (f', _)), ... } )
                                                    =>
                                                    (    f == f'
                                                    and  pg::pen_match (used_mask, pen, desc)
                                                    );

                                                match (IN_USE_GC { desc, ... } )
                                                    =>
                                                    pg::pen_match (used_mask, pen, desc);
                                            end;
                                        end;
                                esac;


                            fun f []
                                    =>
                                    NULL;

                                f (arg ! r)
                                    =>
                                    if (match arg)
                                        #
                                        arg ->  IN_USE_GC { refcount, used, ... };
                                        #
                                        refcount := *refcount + 1;
                                        used := (*used | used_mask);
                                        THE arg;
                                    else
                                        f r;
                                    fi;
                            end;
                        end;

                    # Search the list of free graphics contexts for a match.
                    #
                    # If none is found, then take the last one and
                    # modify it to work.  If the list is empty,
                    # then create a new graphics context.
                    #
                    fun match_free_gc (hit, miss, pen, used_mask, font, free_gcs)
                        =
                        f (free_gcs, [])
                        where

                            # Append second argument to
                            # reversed first argument:
                            #
                            fun revappend ([],    l) =>  l;
                                revappend (x ! r, l) =>  revappend (r, x ! l);
                            end;

                            my (match, make_used)
                                =
                                case font
                                    #
                                    NULL
                                        =>
                                        (match, make_used)
                                        where
                                            fun match (FREE_GC { desc, ... } )
                                                =
                                                pg::pen_match (used_mask, pen, desc);

                                            fun make_used (FREE_GC { gc_id, desc, font } )
                                                =
                                                IN_USE_GC
                                                  { gc_id,
                                                    desc,
                                                    font     =>  REF font,
                                                    used     =>  REF used_mask,
                                                    refcount =>  REF 1
                                                  };
                                        end;

                                    THE fid                                     # "fid" may be "font id"
                                        =>
                                        (match, make_used)
                                        where

                                            fun match (FREE_GC { desc, font => NO_FONT, ... } )
                                                    =>
                                                    FALSE;

                                                match (FREE_GC { desc, font => UNUSED_FONT f, ... } )
                                                    =>
                                                    f == fid
                                                    and
                                                    pg::pen_match (used_mask, pen, desc);

                                                match (FREE_GC { font => (IN_USE_FONT _), ... } )
                                                    =>
                                                    xgripe::impossible "[Pen_Imp: used font in avail gc]";
                                            end;

                                            fun make_used (FREE_GC { gc_id, desc, ... } )
                                                =
                                                IN_USE_GC {
                                                    gc_id,
                                                    desc,
                                                    font     =>  REF (IN_USE_FONT (fid, 1)),
                                                    used     =>  REF used_mask,
                                                    refcount =>  REF 1
                                                };

                                        end;

                                esac;


                            fun f ([], l)
                                    =>
                                    (make_gc (pen, used_mask, font), 0, 0, revappend (l, []));

                                f ([last as FREE_GC _ ], l)
                                    =>
                                    if (match last)
                                        #
                                        (make_used last, hit+1, miss, revappend (l, []));
                                    else
                                        if (hit_rate (hit, miss) < min_hit_rate)
                                            #
                                            (make_gc (pen, used_mask, font), 0, 0, revappend (l, [last]));
                                        else
                                            (change_gc (last, pen, used_mask, font), hit, miss+1, revappend (l, []));
                                        fi;
                                    fi;

                                f (x ! r, l)
                                    =>
                                    if (match x)
                                        #
                                        (make_used x, hit+1, miss, revappend (l, r));
                                    else
                                        f (r, x ! l);
                                    fi;
                            end;

                        end;

                    # This is the imp's outer loop.  As usual,
                    # the parameters constitute our state vector;
                    # We update our state vector just by calling
                    # ourself in tail-recursive fashion.
                    #
                    # Our four arguments together constitute our
                    # gc cache state:
                    #
                    #     'hit' and 'miss' track our cache hit ratio.
                    #          We use this information to manage the
                    #          cache size, which is to say, the number
                    #          of server-side graphics contexts used.
                    #
                    #     'free_gcs' is our freelist of gcs available
                    #          for assignment to any pen.
                    #
                    #     'in_use_gcs' is our list of gcs currently in use.
                    #           
                    fun imp_loop
                        ( hit:         Int,
                          miss:        Int,
                          in_use_gcs:  List( In_Use_Gc ),
                          free_gcs:    List( Free_Gc )
                        )
                        =
                        case (take  plea_slot)
                            #
                            ACQUIRE_GC { pen, used=>used_mask }
                                =>
                                case (match_in_use_gc (pen, used_mask, NULL, in_use_gcs))
                                    #
                                    THE (IN_USE_GC { gc_id, ... } )
                                        =>
                                        {   give (reply_slot, REPLY_GC gc_id);
                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                    NULL
                                        =>
                                        {   my (x as IN_USE_GC { gc_id, ... }, h, m, a)
                                                =
                                                match_free_gc (hit, miss, pen, used_mask, NULL, free_gcs);

                                            give (reply_slot, REPLY_GC gc_id);

                                            imp_loop (h, m, x ! in_use_gcs, a);
                                        };
                                esac;

                            ACQUIRE_GC_WITH_FONT { pen, used=>used_mask, fid=>f_id }
                                =>
                                case (match_in_use_gc (pen, used_mask, NULL, in_use_gcs))
                                    #
                                    THE (IN_USE_GC { gc_id, font as (REF NO_FONT), ... } )
                                        =>
                                        {   set_font (gc_id, f_id);

                                            font := IN_USE_FONT (f_id, 1);

                                            give (reply_slot, REPLY_GC_WITH_FONT (gc_id, f_id));

                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                    THE (IN_USE_GC { gc_id, font as (REF (UNUSED_FONT f)), ... } )
                                        =>
                                        {   if (f != f_id)
                                                  set_font (gc_id, f_id);
                                                  font := IN_USE_FONT (f_id, 1);
                                            else  font := IN_USE_FONT (f_id, 1);
                                            fi;

                                            give (reply_slot, REPLY_GC_WITH_FONT (gc_id, f_id));

                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                    THE (IN_USE_GC { gc_id, font as (REF (IN_USE_FONT (f, n))), ... } )
                                        =>
                                        {   font := IN_USE_FONT (f, n+1);

                                            give (reply_slot, REPLY_GC_WITH_FONT (gc_id, f));

                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                    NULL
                                        =>
                                        {   my (x as IN_USE_GC { gc_id, ... }, h, m, a)
                                                =
                                                match_free_gc( hit, miss, pen, used_mask, THE f_id, free_gcs);

                                            give (reply_slot, REPLY_GC_WITH_FONT (gc_id, f_id));

                                            imp_loop (h, m, x ! in_use_gcs, a);
                                        };
                                esac;

                            ACQUIRE_GC_AND_SET_FONT { pen, used=>used_mask, fid=>f_id }
                                =>
                                case (match_in_use_gc (pen, used_mask, THE f_id, in_use_gcs))
                                    #
                                    THE (IN_USE_GC { gc_id, font as (REF NO_FONT), ... } )
                                        =>
                                        {   set_font (gc_id, f_id);

                                            font := IN_USE_FONT (f_id, 1);

                                            give (reply_slot, REPLY_GC gc_id);

                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                   THE (IN_USE_GC { gc_id, font as (REF (UNUSED_FONT f)), ... } )
                                        =>
                                        {   if (f != f_id)
                                                set_font (gc_id, f_id);
                                            fi;

                                            font := IN_USE_FONT (f_id, 1);

                                            give (reply_slot, REPLY_GC gc_id);

                                            imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                        };

                                   THE (IN_USE_GC { gc_id, font as (REF (IN_USE_FONT (f, n))), ... } )
                                       =>
                                       {   font := IN_USE_FONT (f, n+1);                #  NOTE: f = fId! 

                                           give (reply_slot, REPLY_GC gc_id);

                                           imp_loop (hit+1, miss, in_use_gcs, free_gcs);
                                       };

                                   NULL
                                       =>
                                       {   my (x as IN_USE_GC { gc_id, ... }, h, m, a)
                                               =
                                               match_free_gc( hit, miss, pen, used_mask, THE f_id, free_gcs);

                                           give (reply_slot, REPLY_GC gc_id);

                                           imp_loop (h, m, x ! in_use_gcs, a);
                                       };
                                esac;

                            RELEASE_GC id
                                =>
                                case (find_in_use_gc (id, FALSE, in_use_gcs))
                                    #
                                    THE (x, l) =>  imp_loop (hit, miss, l, x !      free_gcs);
                                    NULL       =>  imp_loop (hit, miss, in_use_gcs, free_gcs);
                                esac;

                            RELEASE_GC_AND_FONT id
                                =>
                                case (find_in_use_gc (id, TRUE, in_use_gcs))
                                    #
                                    THE (x, l) =>  imp_loop (hit, miss, l, x !      free_gcs);
                                    NULL       =>  imp_loop (hit, miss, in_use_gcs, free_gcs);
                                esac;
                        esac;



                    xtr::make_thread  "pen_imp"  .{
                        #
                        imp_loop (0, 0, [default_gc], []);
                    };

                    PEN_TO_GCONTEXT_IMP { plea_slot, reply_slot };

                };                                      # fun make_pen_to_gcontext_imp 

            fun acquire_fn msg_kind (PEN_TO_GCONTEXT_IMP { plea_slot, reply_slot })  arg
                =
                {   give (plea_slot, msg_kind arg);

                    case (take  reply_slot)
                        #
                        REPLY_GC id =>  id;
                        _           =>  xgripe::impossible "[Pen_Imp::acquireFn: bad reply]";
                    esac;
                };

            allocate_graphics_context = acquire_fn ACQUIRE_GC;
            allocate_graphics_context_and_set_font = acquire_fn ACQUIRE_GC_AND_SET_FONT;

            fun allocate_graphics_context_with_font (PEN_TO_GCONTEXT_IMP { plea_slot, reply_slot })  arg
                =
                {   give  (plea_slot, ACQUIRE_GC_WITH_FONT arg);

                    case (take  reply_slot)
                        #
                        REPLY_GC_WITH_FONT arg
                            =>
                            arg;

                        _   =>
                            xgripe::impossible "[pen_to_gcontext_imp::allocate_graphics_context_with_find: bad reply]";
                    esac;
                };


            fun free_graphics_context (PEN_TO_GCONTEXT_IMP { plea_slot, ... })  gc_id
                =
                give  (plea_slot, RELEASE_GC gc_id);


            fun free_graphics_context_and_font
                    #
                    (PEN_TO_GCONTEXT_IMP { plea_slot, ... })
                    #
                    arg
                =
                #
                give  (plea_slot,  RELEASE_GC_AND_FONT arg);


            #  +DEBUG 
            stipulate
                fun pr (s, gc)
                    =
                    trace .{
                        cat [ thread_to_string (get_current_thread()), " ", s, ": gc = ",
                              xid_to_string gc
                            ];
                    };
            herein
                allocate_graphics_context
                    =
                    (fn a =
                    (fn arg
                        =
                        {   gc = allocate_graphics_context  a  arg;
                            pr("allocate_graphics_context", gc);
                            gc;
                        }
                    ));

                allocate_graphics_context_and_set_font
                    =
                    (fn a =
                    (fn arg
                        =
                        {   gc = allocate_graphics_context_and_set_font  a  arg;

                            pr("allocate_graphics_context_and_set_font", gc);

                            gc;
                        }
                    ));

                allocate_graphics_context_with_font
                    =
                    (fn a =
                    (fn arg
                        =
                        {   my result as (gc, _)
                                =
                                allocate_graphics_context_with_font  a  arg;

                            pr("allocate_graphics_context_with_font", gc);

                            result;
                        }
                    ));

                free_graphics_context
                    =
                    (fn a =
                    (fn gc
                        =
                        {   pr("free_graphics_context", gc);
                            #
                            free_graphics_context  a  gc;
                        }
                    ));

                free_graphics_context_and_font
                    =
                    (fn a =
                    (fn gc
                        =
                        {   pr("free_graphics_context_and_font", gc);
                            #
                            free_graphics_context_and_font  a  gc;
                        }
                    ));
            end;
            #  -DEBUG 

        end;    # stipulate
    };          # package pen_to_gcontext_imp
end;            # stipulate


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext