-- (C) Copyright International Business Machines Corporation 23 January 
-- 1990.  All Rights Reserved. 
--  
-- See the file USERAGREEMENT distributed with this software for full 
-- terms and conditions of use. 
-- File: breakselector.pp
-- Author: Andy Lowry
-- SCCS Info: @(#)breakselector.pp	1.7 3/13/90

-- Bug: make sure when we reassemble the additional tests, the
-- original boolean variable is used as the final result.

-- This process decides on the most appropriate means of performing a
-- lookup on a table, based on the selector.  Four possibilities
-- exist: 'scan', meaning that an exhaustive scan must be done;
-- 'index' meaning that one of the indexes available for the table can
-- be used; 'key' meaning that one of the keys associated with the
-- table definition can be used; and 'position' which applies to
-- ordered tables where the position of the required element is known.
-- In all cases, the base lookup method may cover only part of the
-- specification present in the selector, so that further tests on the
-- retrieved element must also be performed.  Thus in addition to
-- specifying a lookup method and associated lookup parameters, a list
-- of additional test statements is also returned; those statements
-- will result in all additional required tests being applied to the
-- retrieved element, and a boolean result ('true' if all tests are
-- passed) being placed in the 'result' object identified in the
-- selector.

-- ** N.B.: Coercions attached to selector clauses are currently thrown
-- ** away

-- ** N.B.: This module depends heavily on the format of Hermes
-- statements that can occur within expressions.


#include "typemark.h"
#include "codegen.h"

breakSelector: using (cgInternal, exprTree)
#ifndef LIGEN
  linking (makeExpr, exprAssemble, exprUsesRoot)
#endif
process (Q: breakSelectorQ)

declare
  args: breakSelector;
#ifndef LIGEN
  stmts: statements;
  eltObj: predefined!objectname;
  expr: exprTree!expr;
  eqTests: exprTrees;
  conjuncts: exprTree!exprList;
  bools: predefined!objectnames;
  keys: predefined!formal_objects;
  keyExprs: exprTree!exprList;
  makeExpr: makeExprFn;
  exprUsesRoot: exprUsesRootFn;
  exprAssemble: exprAssembleFn;
#endif LIGEN
  empty: empty;
begin
  receive args from Q;
  
#ifndef LIGEN
  if B(exists of opt in args.cgData.options[S("quick-compile")]) then
#endif LIGEN
    -- Skip all the fancy stuff... just make them use a 'scan' style
    -- loop
    unite args.lookup.scan from empty;
    args.newresult := args.selector.result;
    inspect proc in ABSPROG.programs[args.cgData.Proc.id] begin
      inspect scope in proc.executable_part.scopes[args.selector.scope] begin
	inspect clause in proc.executable_part.clauses[scope.clause] begin
	  args.tests := clause.statements;
	end inspect;
      end inspect;
    end inspect;
    return args;
    exit done;
#ifndef LIGEN
  end if;

  -- Get the selector element object as a normal objectname
  new eltObj;
  new eltObj.root;
  eltObj.root.root := args.selector.element;
  eltObj.root.scope := args.selector.scope;
  new eltObj.components;

  -- Spawn a few utility processes that we're going to need
  makeExpr <- makeExprFn#(create of program#(process makeExpr));
  exprAssemble <- exprAssembleFn#(procedure of program#(process exprAssemble));
  exprUsesRoot <- exprUsesRootFn#(procedure of program#(process exprUsesRoot));

  -- Reorganize the statements in the selector expression into an
  -- expression tree (this is possible due to the constraints on what
  -- can appear in expressions).
  inspect proc in ABSPROG.programs[args.cgData.Proc.id] begin
    inspect scope in proc.executable_part.scopes[args.selector.scope] begin
      inspect clause in proc.executable_part.clauses[scope.clause] begin
	expr <- exprTree!expr#
	    (makeExpr(args.selector.result,clause.statements));
      end inspect;
    end inspect;
  end inspect;
  
  -- Extract all the conjuncts from the expression tree, and sort them
  -- into '=' tests and others
  new bools;
  block declare
    workList: exprTree!exprList;
  begin
    new worklist;
    insert expr into workList;
    new eqTests;
    new conjuncts;
    while B(I(size of workList) > ZERO) repeat
      remove expr from workList[];
      if B(exprType#(case of expr) = exprType#'tree') then
	reveal expr.tree;
	if B(expr.tree.opcode = predefined!operator#'and') then
	  -- AND stmt... discard this expr but work on its operands
	  merge exprList#(copy of expr.tree.args) into workList;
	  insert objectname#(copy of expr.tree.dst) into bools;
	else
	  if B(expr.tree.opcode = predefined!operator#'equal') then
	    -- EQUAL stmt
	    insert exprTree#(copy of expr.tree) into eqTests;
	  else
	    -- some other stmt
	    insert expr into conjuncts;
	  end if;
	end if;
      else
	-- Not a tree node... this conjunct is just some object
	-- computed prior to the selector expression
	insert expr into conjuncts;
      end if;
    end while;
  end block;
  
  -- Check for an EQUAL test involving the element position.  The
  -- other EQUAL operand must not make use of the element variable.
  for posTest in eqTests[] inspect
    block declare
      x: exprTree!expr;
      posExpr: exprTree!expr;
    begin
      x <- exprTree!expr#(AREF(tmp,posTest.args,ZERO));
      if B(exprType#(case of x) = exprType#'tree') then
	reveal x.tree;
	if B(x.tree.opcode = predefined!operator#'position_of_element') then
	  x <- exprTree!expr#(AREF(tmp,x.tree.args,ZERO));
	  if B(exprType#(case of x) = exprType#'object') then
	    reveal x.obj;
	    if B(x.obj = eltObj) then
	      -- 1st operand is correct POSITION OF expression -- make
	      -- sure 2nd operand doesn't reference element var
	      posExpr <- exprTree!expr#(AREF(tmp,posTest.args,ONE));
	      if B(not B(exprUsesRoot(posExpr,eltObj.root))) then
		-- OK... set up for a position style lookup
		exit usePosition;
	      end if;
	    end if;
	  end if;
	end if;
      end if;
      -- Now do a similar test based on the 2nd argument (ugh!)
      x <- exprTree!expr#(AREF(tmp,posTest.args,ONE));
      if B(exprType#(case of x) = exprType#'tree') then
	reveal x.tree;
	if B(x.tree.opcode = predefined!operator#'position_of_element') then
	  x <- exprTree!expr#(AREF(tmp,x.tree.args,ZERO));
	  if B(exprType#(case of x) = exprType#'object') then
	    reveal x.obj;
	    if B(x.obj = eltObj) then
	      -- 2nd operand is correct POSITION OF expression -- make
	      -- sure 1st operand doesn't reference element var
	      posExpr <- exprTree!expr#(AREF(tmp,posTest.args,ZERO));
	      if B(not B(exprUsesRoot(posExpr,eltObj.root))) then
		-- OK... set up for a position style lookup
		exit usePosition;
	      end if;
	    end if;
	  end if;
	end if;
      end if;
    on exit(usePosition)
      -- Here when we found an EQUAL test that could be used for a
      -- position style lookup
      block declare
	lv: lookupValue;
	e: exprTree!expr;
      begin
	new lv;
	lv.computation <- statements#(exprAssemble(posExpr));
	if B(exprType#(case of posExpr) = exprType#'tree') then
	  reveal posExpr.tree;
	  lv.result := posExpr.tree.dst;
	else
	  reveal posExpr.obj;
	  lv.result := posExpr.obj;
	end if;
	unite args.lookup.posn from lv;
	-- All other EQUAL tests go with the other conjuncts
	for test in eqTests where B(test <> posTest) inspect
	  unite e.tree from exprTree#(copy of test);
	  insert e into conjuncts;
	end for;
	-- boolean destination variable for this test goes in the pool
	insert objectname#(copy of posTest.dst) into bools;
	exit decided;
      end block;
    end block;
  end for;
  
  -- Here when no suitable POSITION test could be located... try for a
  -- keyed or indexed lookup next
  
  -- Gather all the tests that can be used in key/index lookups
  new keys;
  new keyExprs;
  block declare eqTestsCopy: exprTrees; begin eqTestsCopy := eqTests;
  for test in eqTestsCopy[] inspect
    block declare
      x: exprTree!expr;
      key: component_list;
      keyval: exprTree!expr;
    begin
      -- see if 1st operand is an object rooted at the element variable
      x <- exprTree!expr#(AREF(tmp,test.args,ZERO));
      if B(exprType#(case of x) = exprType#'object') then
	reveal x.obj;
	if B(x.obj.root = eltObj.root) then
	  -- yes... make sure 2nd operand doesn't reference element var
	  keyval <- exprTree!expr#(AREF(tmp,test.args,ONE));
	  if B(not B(exprUsesRoot(keyval,eltObj.root))) then
	    -- Got it... remember the pieces and add it to available
	    -- keys list
	    key := x.obj.components;
	    exit availKey;
	  end if;
	end if;
      end if;
      -- again, with operands swapped
      x <- exprTree!expr#(AREF(tmp,test.args,ONE));
      if B(exprType#(case of x) = exprType#'object') then
	reveal x.obj;
	if B(x.obj.root = eltObj.root) then
	  -- 2nd operand ok... make sure 1st doesn't reference element var
	  keyval <- exprTree!expr#(AREF(tmp,test.args,ZERO));
	  if B(not B(exprUsesRoot(keyval,eltObj.root))) then
	    -- Got it... remember the pieces and add it to available
	    -- keys list
	    key := x.obj.components;
	    exit availKey;
	  end if;
	end if;
      end if;

      -- Test is not usable for keyed/indexed lookup... put it back in
      -- normal conjuncts list
      block declare
	e: exprTree!expr;
      begin
	unite e.tree from exprTree#(copy of test);
	insert e into conjuncts;
      end block;
      
    on exit(availKey)
      -- Here when we have an EQUAL test that might be usable in a
      -- keyed/indexed lookup.  Save the vital info and remove this
      -- test from the eqTests collection
      insert key into keys;
      insert keyval into keyExprs;
      block declare
	tree: exprTree;
      begin
	remove tree from tmp in eqTests where (B(tmp = test));
	insert objectname#(copy of tree.dst) into bools;
      end block;
    end block;
  end for;
  end block;
  discard eqTests;		-- don't need these anymore

  -- Try to find a key/index set for the table being scanned, which is
  -- covered by the key expressions we have available.
  block declare
    tdef: type_definition;	-- the source table's type definition
    tblKeys: predefined!keyset;
    repno: integer;
  begin
    tdef <- type_definition#(FNS.typeDef(args.tblType));
    reveal tdef.specification.table_info;
    tblKeys := tdef.specification.table_info.keys;
    -- Look for a key that's covered
    block begin
      inspect key in tblKeys where
	    (B(forall of comps in key where 
		(B(exists of availKey in keys where B(comps = availKey)))))
      begin
	-- Found a usable key... use it!
	block declare
	  ld: lookupData;
	  lv: lookupValue;
	  pos: integer;
	  keyExpr: exprTree!expr;
	  junk: component_list;
	begin
	  -- build up the lookup info structure
	  new ld;
	  ld.repno <- I(position of key);
	  new ld.values;
	  for comps in key[] inspect
	    pos <- I(position of availKey in keys where B(comps = availKey));
	    remove junk from AREF(tmp,keys,pos);
	    remove keyExpr from AREF(tmp,keyExprs,pos);
	    new lv;
	    lv.computation <- statements#(exprAssemble(keyExpr));
	    if B(exprType#(case of keyExpr) = exprType#'tree') then
	      reveal keyExpr.tree;
	      lv.result := keyExpr.tree.dst;
	    else
	      reveal keyExpr.obj;
	      lv.result := keyExpr.obj;
	    end if;
	    insert lv into ld.values;
	  end for;
	  unite args.lookup.key from ld;
	  exit mergeUnusedKeys;
	end block;
      end inspect;
    on (NotFound)
      -- No key was covered... go on and try for a covered index
    end block;
    
    -- Here to try to find a covered index
    -- NYI...
    
    -- Here when neither keyed nor indexed lookup can be done... use
    -- scan style instead
    unite args.lookup.scan from empty;
    exit mergeUnusedKeys;

  on exit(mergeUnusedKeys)
    -- Here when a lookup method has been chosen but there are broken
    -- out key/index candidates that need to be assembled back into
    -- EQUAL tests
    block declare
      eqTest: exprTree!expr;
      obj: objectname;
      bool: objectname;
      objExpr: exprTree!expr;
      tree: exprTree;
    begin
      for keyExpr in keyExprs[] inspect
	new obj;
	obj.root := eltObj.root;
	obj.components := component_list#
	    (AREF(tmp,keys,I(position of keyExpr)));
	unite objExpr.obj from obj;
	new tree;
	tree.opcode <- predefined!operator#'equal';
	remove bool from bools[];
	tree.dst <- bool;
	new tree.args;
	insert objExpr into tree.args;
	unite tree.qual.empty from empty;
	new tree.prag;
	insert exprTree!expr#(copy of keyExpr) into tree.args;
	unite eqTest.tree from tree;
	insert eqTest into conjuncts;
      end for;
    end block;
    exit decided;
  end block;
  
on exit(decided)
  -- Here when the lookup structure is all set... We need to generate
  -- code for all the leftover expressions, as well as AND statements
  -- to join their results.
  while B(I(size of conjuncts) > ONE) repeat
    block declare
      andNode: exprTree!expr;
      tree: exprTree;
      arg: exprTree!expr;
    begin
      new tree;
      tree.opcode <- predefined!operator#'and';
      remove tree.dst from bools[];
      new tree.args;
      remove arg from conjuncts[];
      insert arg into tree.args;
      remove arg from conjuncts[];
      insert arg into tree.args;
      unite tree.qual.empty from empty;
      new tree.prag;
      unite andNode.tree from tree;
      insert andNode into conjuncts;
    end block;
  end while;

  -- Special case... test if remaining tests are a constant 'true'
  if B(I(size of conjuncts) = ONE) then
    block begin
      remove expr from conjuncts[];
      if B(exprType#(case of expr) <> exprType#'tree') then
	exit needTest;
      end if;
      reveal expr.tree;
      if B(expr.tree.opcode <> predefined!operator#'named_literal') then
	exit needTest;
      end if;
      reveal expr.tree.qual.literal;
      block declare
	tdef: type_definition;
      begin
	tdef <- type_definition#(FNS.typeDef(
	    typename#(args.cgData.Proc.objType(expr.tree.dst))));
	if B(primitive_types#(case of tdef.specification) <>
		primitive_types#'booleantype') then
	  exit needTest;
	end if;
	reveal tdef.specification.boolean;
	if B(expr.tree.qual.literal <> tdef.specification.boolean.true_name)
	then
	  exit needTest;
	end if;
      end block;
      -- sole test consisted of a boolean 'true' expression... leave
      -- it out completely
    on exit(needTest)
      -- test was something other than a boolean 'true'... put it back
      -- in so it will get codegened
      insert expr into conjuncts;
    end block;
  end if;
  
  if B(I(size of conjuncts) = ZERO) then
    new args.tests;		-- no additional test statements
    args.newresult := args.selector.result;
  else
    remove expr from conjuncts[];
    args.tests <- statements#(exprAssemble(expr));
    if B(exprType#(case of expr) = exprType#'tree') then
      reveal expr.tree;
      args.newresult := expr.tree.dst;
    else
      reveal expr.obj;
      args.newresult := expr.obj;
    end if;
  end if;

  -- All finished!
  return args;

#endif LIGEN

on exit(done)
  -- Jump here if the "QUICK-COMPILE" option was given
end process
