## pen-cache.pkg
#
# Track graphics-contexts in the X server.
#
# Reppy had this as a full-fledged imp
#
# src/lib/x-kit/xclient/src/window/pen-to-gcontext-imp-old.pkg#
# but it wound up only used by
#
# src/lib/x-kit/xclient/src/window/xserver-ximp.pkg#
# so it got demoted to a support package. It is used only by a
# single xserver-ximp microthread, so we have no concurrency issues.
# -- 2013-07-17 CrT
#
# For the big picture see the imp dataflow diagrams in
#
# src/lib/x-kit/xclient/src/window/xclient-ximps.pkg#
# NB: Throughout this file, "gc" == "(X11) graphics context"
# -- NOT "garbage collector"!
# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublibstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
#
package un = unt; # unt is from src/lib/std/unt.pkg package rwv = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg package vec = vector; # vector is from src/lib/std/src/vector.pkg package v1u = vector_of_one_byte_unts; # vector_of_one_byte_unts is from src/lib/std/src/vector-of-one-byte-unts.pkg package v2w = value_to_wire; # value_to_wire is from src/lib/x-kit/xclient/src/wire/value-to-wire.pkg package w2v = wire_to_value; # wire_to_value is from src/lib/x-kit/xclient/src/wire/wire-to-value.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkg package pg = pen_guts; # pen_guts is from src/lib/x-kit/xclient/src/window/pen-guts.pkg package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg #
trace = xtr::log_if xtr::io_logging 0; # Conditionally write strings to tracing.log or whatever.
herein
package pen_cache
: (weak) Pen_Cache # Pen_Cache is from src/lib/x-kit/xclient/src/window/pen-cache.api {
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.
min_hit_rate = 80; # We want at least 80% of GC requests to be matched.
# 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.
#
# 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.
pen: pg::Pen, # Describes 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.
pen: pg::Pen, # Describes values of the GC.
font: Ref( Font_Status ), # The current font (if any).
used_mask: 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.
};
Pen_Cache # All nonephemeral pen-cache state.
=
{ hits: Ref(Int),
misses: Ref(Int),
in_use_gcs: Ref( List(In_Use_Gc) ),
free_gcs: Ref( List( Free_Gc) ),
#
drawable: xt::Drawable_Id,
next_xid: Void -> xt::Xid, # resource id allocator. Implemented by spawn_xid_factory_thread() from src/lib/x-kit/xclient/src/wire/display-old.pkg default_gcid: xt::Graphics_Context_Id
};
fun font_sts2s (NO_FONT) => "NoFont";
font_sts2s (UNUSED_FONT f) => string::cat ["UNUSED_FONT(", xt::xid_to_string f, ")"];
font_sts2s (IN_USE_FONT (f, n)) => string::cat [ "IN_USE_FONT(", xt::xid_to_string f, ", ", int::to_string n, ")" ];
end;
#
fun in_use_gc_to_string (IN_USE_GC { gc_id, pen, font, used_mask, refcount } )
=
string::cat
[
"IN_USE_GC { gc_id=", xt::xid_to_string gc_id, ", font=", font_sts2s *font,
", refcount=", int::to_string *refcount, "}"
];
# 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, pen, font, ... })
=>
THE (FREE_GC { gc_id, pen, font => *font }, rest); # Removing last reference makes GC free.
(TRUE, IN_USE_GC { refcount => REF 1, pen, font => REF (IN_USE_FONT (f, 1)), ... })
=>
THE (FREE_GC { gc_id, pen, 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;
(vec::from_list (map bitmask l), vec::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 | penslot_to_gcmask[i]);
end;
end;
#
fun hit_rate (hits, misses)
=
{ total = hits + misses;
if (total == 0) 100;
else int::quot((100 * hits), total);
fi;
};
# 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 ({ traits, ... }: pg::Pen, dst_mask, font)
=
{ gc_vals = rwv::make_rw_vector (gc_slot_count, NULL);
#
fun update (i, v) = gc_vals[i] := THE (unt::from_int v);
fun update_u (i, v) = gc_vals[i] := THE v;
#
fun init_val (i, pg::IS_WIRE v)
=>
update_u (penslot_to_gcslot[i], v);
init_val (i, pg::IS_POINT ({ col, row } ))
=>
{ j = penslot_to_gcslot[i];
update (j, col);
update (j+1, row);
};
init_val (i, pg::IS_PIXMAP xid)
=>
update_u (penslot_to_gcslot[i], xt::xid_to_unt xid);
init_val _
=>
();
end;
#
fun init_vals (0u0, _)
=>
();
init_vals (m, i)
=>
{ if ((m & 0u1) != 0u0)
#
init_val (i, traits[i]);
fi;
init_vals (m >> 0u1, i+1);
};
end;
case font
#
THE font_id => update_u (font_gcslot, xt::xid_to_unt font_id);
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 (traits[clip_mask_penslot])
#
pg::IS_BOXES boxes
=>
(THE (traits[ clip_origin_penslot ], boxes));
_ => NULL;
esac;
fi,
dashes => if ((dst_mask & (0u1 << unt::from_int dashlist_penslot)) == 0u0)
#
NULL;
else
case (traits[ dashlist_penslot ])
#
pg::IS_DASHES dashes
=>
THE (traits[ dash_offset_penslot ], dashes);
_ => NULL;
esac;
fi
};
}; # fun pen_to_gcvals
#
fun set_dashes (_, NULL, note_xrequest)
=>
();
set_dashes (gc_id, THE (pg::IS_WIRE offset, dashes), note_xrequest)
=>
note_xrequest (v2w::encode_set_dashes { gc_id, dashes, dash_offset => unt::to_int_x offset });
set_dashes (gc_id, THE(_, dashes), note_xrequest)
=>
note_xrequest (v2w::encode_set_dashes { gc_id, dashes, dash_offset => 0 });
end;
#
fun set_clip_boxes (_, NULL, note_xrequest)
=>
();
set_clip_boxes (gc_id, THE (pg::IS_POINT pt, (order, boxes)), note_xrequest)
=>
note_xrequest (v2w::encode_set_clip_boxes { gc_id, boxes, clip_origin => pt, ordering => order });
set_clip_boxes (gc_id, THE(_, (order, boxes)), note_xrequest)
=>
note_xrequest (v2w::encode_set_clip_boxes { gc_id, clip_origin => g2d::point::zero, ordering => order, boxes });
end;
# Set the font of a GC:
#
fun set_font (gc_id, font_id, note_xrequest)
=
{ vals = rwv::make_rw_vector (gc_slot_count, NULL);
#
vals[font_gcslot] := THE (xt::xid_to_unt font_id);
note_xrequest (v2w::encode_change_gc { gc_id, vals => xt::VALUE_LIST vals });
};
# Create a new X-server graphics context.
# It is in-use by definition:
#
fun make_gc (pen as { bitmask, ... }: pg::Pen, used_mask, font, drawable, next_xid, note_xrequest)
=
{ (pen_to_gcvals (pen, bitmask, font))
->
{ vals, dashes, clip_boxes };
gc_id = next_xid();
note_xrequest (v2w::encode_create_gc { gc_id, drawable, vals });
set_dashes (gc_id, dashes, note_xrequest);
set_clip_boxes (gc_id, clip_boxes, note_xrequest);
IN_USE_GC { gc_id,
pen,
refcount => REF 1,
#
used_mask => REF used_mask,
font => REF case font NULL => NO_FONT;
THE f => IN_USE_FONT (f, 1);
esac
};
};
# 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 { bitmask, ... }: pg::Pen,
used_mask,
new_font,
default_gcid,
note_xrequest
)
=
{ 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 font_id ) => (TRUE, IN_USE_FONT (font_id, 1));
(UNUSED_FONT font_id1, THE font_id2) => ((font_id1 != font_id2), IN_USE_FONT (font_id2, 1));
(IN_USE_FONT _, _ ) => xgripe::impossible "[Pen_Imp: used font in free_gcs gc]";
esac;
if (default_mask != 0u0)
#
note_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 };
note_xrequest (v2w::encode_change_gc { gc_id, vals });
set_dashes (gc_id, dashes, note_xrequest);
set_clip_boxes (gc_id, clip_boxes, note_xrequest);
fi;
IN_USE_GC { gc_id,
pen,
font => REF font,
used_mask => 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, note_xrequest)
=
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, pen')
#
match = case font
#
NULL => (\\ (IN_USE_GC { pen => pen', ... } )
=
pg::pen_match (used_mask, pen, pen')
);
THE f => match
where
fun match (IN_USE_GC { pen => pen', font => REF (IN_USE_FONT (f', _)), ... } )
=>
( f == f'
and pg::pen_match (used_mask, pen, pen')
);
match (IN_USE_GC { pen => pen', ... } )
=>
pg::pen_match (used_mask, pen, pen');
end;
end;
esac;
#
fun f [] => NULL;
#
f (arg ! r)
=>
if (match arg)
#
arg -> IN_USE_GC { refcount, used_mask => used_mask', ... };
#
refcount := *refcount + 1;
used_mask' := (*used_mask' | 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 (hits, misses, pen, used_mask, font, free_gcs, drawable, next_xid, default_gcid, note_xrequest)
=
match_free_gc' (free_gcs, [])
where
# Reverse first arg and prepend it to second arg:
#
fun reverse_and_prepend ([], l) => l;
reverse_and_prepend (x ! r, l) => reverse_and_prepend (r, x ! l);
end;
my (match, make_used)
=
case font
#
NULL => (match, make_used)
where
fun match (FREE_GC { pen => pen', ... } )
=
pg::pen_match (used_mask, pen, pen');
#
fun make_used (FREE_GC { gc_id, pen, font } )
=
IN_USE_GC { gc_id,
pen,
font => REF font,
used_mask => REF used_mask,
refcount => REF 1
};
end;
THE font_id => (match, make_used)
where
#
fun match (FREE_GC { font => NO_FONT, ... } )
=>
FALSE;
match (FREE_GC { pen => pen', font => UNUSED_FONT f, ... } )
=>
f == font_id
and
pg::pen_match (used_mask, pen, pen');
match (FREE_GC { font => (IN_USE_FONT _), ... } )
=>
xgripe::impossible "[Pen_Imp: used font in avail gc]";
end;
#
fun make_used (FREE_GC { gc_id, pen, ... } )
=
IN_USE_GC { gc_id,
pen,
font => REF (IN_USE_FONT (font_id, 1)),
used_mask => REF used_mask,
refcount => REF 1
};
end;
esac;
#
fun match_free_gc' ([], l)
=>
{ in_use_gc => make_gc (pen, used_mask, font, drawable, next_xid, note_xrequest),
free_gcs => reverse_and_prepend (l, []),
hits => 0,
misses => 0
};
match_free_gc' ([last as FREE_GC _ ], l)
=>
if (match last)
#
{ in_use_gc => make_used last,
free_gcs => reverse_and_prepend (l, []),
hits => hits+1,
misses
};
else
if (hit_rate (hits, misses) < min_hit_rate)
#
{ in_use_gc => make_gc (pen, used_mask, font, drawable, next_xid, note_xrequest),
free_gcs => reverse_and_prepend (l, [last]),
hits => 0,
misses => 0
};
else
{ in_use_gc => change_gc (last, pen, used_mask, font, default_gcid, note_xrequest),
free_gcs => reverse_and_prepend (l, []),
hits,
misses => misses+1
};
fi;
fi;
match_free_gc' (x ! r, l)
=>
if (match x)
#
{ in_use_gc => make_used x,
free_gcs => reverse_and_prepend (l, r),
hits => hits+1,
misses
};
else
match_free_gc' (r, x ! l);
fi;
end;
end;
##########################################################################################
# PUBLIC.
#
#
fun allocate_graphics_context (me: Pen_Cache) # PUBLIC.
{
pen: pg::Pen,
used_mask: Unt,
note_xrequest: v1u::Vector -> Void
}
=
case (match_in_use_gc (pen, used_mask, NULL, *me.in_use_gcs, note_xrequest))
#
THE (IN_USE_GC { gc_id, ... } )
=>
{ me.hits := *me.hits + 1;
#
gc_id;
};
NULL
=>
{ (match_free_gc (*me.hits, *me.misses, pen, used_mask, NULL, *me.free_gcs, me.drawable, me.next_xid, me.default_gcid, note_xrequest))
->
{ in_use_gc as IN_USE_GC { gc_id, ... }, hits, misses, free_gcs };
me.hits := hits;
me.misses := misses;
me.in_use_gcs := in_use_gc ! *me.in_use_gcs;
me.free_gcs := free_gcs;
gc_id;
};
esac;
#
fun allocate_graphics_context_with_font (me: Pen_Cache) # PUBLIC.
{ pen: pg::Pen,
used_mask: Unt,
note_xrequest: v1u::Vector -> Void,
font_id: xt::Font_Id
}
=
case (match_in_use_gc (pen, used_mask, NULL, *me.in_use_gcs, note_xrequest))
#
THE (IN_USE_GC { gc_id, font as (REF NO_FONT), ... } )
=>
{ set_font (gc_id, font_id, note_xrequest);
#
font := IN_USE_FONT (font_id, 1);
me.hits := *me.hits + 1;
{ gc_id, font_id };
};
THE (IN_USE_GC { gc_id, font as (REF (UNUSED_FONT f)), ... } )
=>
{ if (f != font_id)
set_font (gc_id, font_id, note_xrequest);
font := IN_USE_FONT (font_id, 1);
else font := IN_USE_FONT (font_id, 1);
fi;
me.hits := *me.hits + 1;
{ gc_id, font_id };
};
THE (IN_USE_GC { gc_id, font as (REF (IN_USE_FONT (f, n))), ... } )
=>
{ font := IN_USE_FONT (f, n+1);
#
me.hits := *me.hits + 1;
{ gc_id, font_id => f };
};
NULL
=>
{ (match_free_gc (*me.hits, *me.misses, pen, used_mask, THE font_id, *me.free_gcs, me.drawable, me.next_xid, me.default_gcid, note_xrequest))
->
{ in_use_gc as IN_USE_GC { gc_id, ... }, hits, misses, free_gcs };
me.hits := hits;
me.misses := misses;
me.in_use_gcs := in_use_gc ! *me.in_use_gcs;
me.free_gcs := free_gcs;
{ gc_id, font_id };
};
esac;
#
fun allocate_graphics_context_and_set_font (me: Pen_Cache) # PUBLIC.
{
pen: pg::Pen,
used_mask: Unt,
note_xrequest: v1u::Vector -> Void,
font_id: xt::Font_Id
}
=
case (match_in_use_gc (pen, used_mask, THE font_id, *me.in_use_gcs, note_xrequest))
#
THE (IN_USE_GC { gc_id, font as (REF NO_FONT), ... } )
=>
{ set_font (gc_id, font_id, note_xrequest);
#
font := IN_USE_FONT (font_id, 1);
me.hits := *me.hits + 1;
gc_id;
};
THE (IN_USE_GC { gc_id, font as (REF (UNUSED_FONT f)), ... } )
=>
{ if (f != font_id)
set_font (gc_id, font_id, note_xrequest);
fi;
font := IN_USE_FONT (font_id, 1);
me.hits := *me.hits + 1;
gc_id;
};
THE (IN_USE_GC { gc_id, font as (REF (IN_USE_FONT (f, n))), ... } )
=>
{ font := IN_USE_FONT (f, n+1); # NOTE: f = fId!
#
me.hits := *me.hits + 1;
gc_id;
};
NULL =>
{ (match_free_gc (*me.hits, *me.misses, pen, used_mask, THE font_id, *me.free_gcs, me.drawable, me.next_xid, me.default_gcid, note_xrequest))
->
{ in_use_gc as IN_USE_GC { gc_id, ... }, hits, misses, free_gcs };
me.hits := hits;
me.misses := misses;
me.in_use_gcs := in_use_gc ! *me.in_use_gcs;
me.free_gcs := free_gcs;
gc_id;
};
esac;
#
fun free_graphics_context (me: Pen_Cache) (id: xt::Graphics_Context_Id) # PUBLIC.
=
case (find_in_use_gc (id, FALSE, *me.in_use_gcs))
#
THE (x, l) => { me.in_use_gcs := l;
me.free_gcs := x ! *me.free_gcs;
};
NULL => {
};
esac;
#
fun free_graphics_context_and_font (me: Pen_Cache) (id: xt::Graphics_Context_Id) # PUBLIC.
=
case (find_in_use_gc (id, TRUE, *me.in_use_gcs))
#
THE (x, l) => { me.in_use_gcs := l;
me.free_gcs := x ! *me.free_gcs;
};
NULL => {
};
esac;
#
fun make_pen_cache # PUBLIC.
{
drawable: xt::Drawable_Id,
next_xid: Void -> xt::Xid, # resource id allocator. Implemented by spawn_xid_factory_thread() from src/lib/x-kit/xclient/src/wire/display-old.pkg note_xrequest: v1u::Vector -> Void
}
=
{
#
(make_gc (pg::default_pen, 0ux7FFFFF, NULL, drawable, next_xid, note_xrequest))
->
IN_USE_GC { gc_id => default_gcid, ... };
{ hits => REF 0,
misses => REF 0,
#
in_use_gcs => REF ([]: List(In_Use_Gc)),
free_gcs => REF ([]: List( Free_Gc)),
#
drawable,
next_xid,
default_gcid
};
};
}; # package pen_cache
end;