cgen.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1995. COPYRIGHT --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in --
-- the file "Doc/License" of the Sather distribution. The license is also --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA. --
--------> Please email comments to sather-bugs@icsi.berkeley.edu. <----------
class CGEN < $BACK_END
class CGEN < $BACK_END is
include CS_COMPONENT;
-- back-end C generation from an AM structure.
-- These are options that may be set from outside CGEN.
attr null_segfaults:BOOL;
attr c_flags:FLIST{STR}; -- Flags to pass to C compiler
attr externals:FMAP{STR,FSET{STR}}; -- Files linked if class reachable
attr executable:STR; -- The executable to output, or void
attr optimize:BOOL; -- Attempt optimizations
attr debug:BOOL; -- Generate debugging information
attr deterministic:BOOL; -- generate id determinism
attr type_tables:BOOL; -- generate type tables
attr func_tables:BOOL; -- generate func tables
attr print_ob:BOOL; -- generate PO() function
attr print_ob_g:BOOL; -- generate POG() function
attr force_routines:FSET{STR}; -- Routines to be generated no matter what
attr force_all:BOOL; -- Force all generation
attr gen_c:BOOL; -- If true, generate C files
attr only_C:BOOL; -- Stop after making C
attr only_check:BOOL; -- Don't do code generation
attr c_files:FSET{STR}; -- C source files
attr object_files:FSET{STR}; -- object files
attr archive_files:FLIST{STR}; -- `library' archive files
attr pretty:BOOL; -- Make generated C look nice
attr builtin_cntr_n:INT; -- used to make uniq vars for builtins
attr zones:BOOL; -- Use zoned runtime (experimental)
-- Options garnered from CONFIG file
attr mangler:MANGLE;
attr gen:GENERATE_AM;
-- These are private state needed for the translation.
private attr in_bnd_rout_call:BOOL; -- true if we are generating the stub for
-- bound routines (only needed with print_ob)
private attr in_bnd_iter_call:BOOL; -- true if we are generating the stub for
-- bound iter (only needed with print_ob)
private attr options:CS_OPTIONS; -- Typesafe options
private attr indent:INT; -- current level of indentation
private attr state_counter:INT; -- for yield goto's
readonly attr sather_h, tags_h, makefile:CODE_FILE;
private attr code_c, system_c, dispatch_c, unbox_c, strings_c:CODE_FILE;
private attr print_c:CODE_FILE;
attr globals_c:CODE_FILE;
-- The header and C files.
private attr code_dir:STR;
-- The directory all this happens in
private attr needs_tag:FSET{$TP};
-- Types which will need tags assigned
readonly attr tags:FMAP{$TP,INT};
-- Integers associated with classes
private attr main_sig:SIG;
-- SIG corresponding to main
private attr current_sig:SIG;
-- SIG of current function being translated
private attr current_am_rout_def:AM_ROUT_DEF;
-- AM_ROUT_DEF of current function being translated
private attr current_function_str:STR;
-- Name of current function being translated
private attr current_arg_list:ARRAY{STR};
-- mangled names of args of current function
private attr current_iter_out_arg_locals:FLIST{AM_LOCAL_EXPR};
-- iter locals used in place of out/inout args to ensure value/result
-- semantics
private attr saw_outer_return:BOOL;
-- was a return at outer level seen in this routine?
private attr chk_pre, chk_post, chk_invariant, chk_assert,
chk_arith, chk_bounds, chk_void, chk_when, chk_return:BOOL;
-- whether different checks are on for the current function
attr nested_its:FMAP{AM_ROUT_DEF,FLIST{AM_ITER_CALL_EXPR}};
-- Stack of iter calls
attr nested_bits:FMAP{AM_ROUT_DEF,FLIST{AM_BND_ITER_CALL_EXPR}};
-- Map of biter calls
private attr current_loop:STR;
-- label to goto to at end of loop
private attr abstract_routs:FLIST{AM_ROUT_DEF};
-- List of abstract routines to make dispatch tables for
private attr abstract_iters:FLIST{AM_ROUT_DEF};
-- List of abstract iters to make dispatch tables for
private attr bnd_rout_creates:FLIST{AM_BND_CREATE_EXPR};
-- List of bound routine stubs to generate
private attr bnd_iter_creates:FLIST{AM_BND_CREATE_EXPR};
-- List of bound iter stubs to generate
private attr itersig_map: FMAP{SIG,AM_ROUT_DEF};
-- an auxiluary datastructure which is filled in emit_am_bnd_iter_create
-- to map iter sigs to their am_rout_defs, which is needed across
-- code_file boundaries
private attr arg_frames:FSET{SIG};
-- List of routs to generate arg frames for
private attr emitted_iter_allocators:FSET{SIG};
-- List of dispatched iters for which allocators have been generated
private attr routine_code:FSTR;
-- code waiting to be emitted
private attr str_count:INT;
-- number of STR constants emitted (for making their id)
private attr string_constants:FMAP{STR,STR};
-- cache of emitted string constants, so we don't duplicate them
private attr not_emitted:FMAP{SIG,AM_ROUT_DEF};
-- routines not initially emitted because they were inlined
private attr leftovers:FSET{AM_ROUT_DEF};
-- routines that need to be generated even though inlined
private attr emitted_leftovers:FSET{AM_ROUT_DEF};
-- leftover routines that have been already emitted
private attr routine_count:INT;
-- count of emitted routines, reset for each new file
private attr inlined_iter_count:INT;
-- count of how many iters got inlined
private attr code_files:FMAP{$TP,CODE_FILE};
private attr abstract_calls, concrete_calls,
inlined_value_ob_eq_calls,
inlined_pointer_ob_eq_calls:INT;
private attr ex_nesting, current_loop_ex_nesting:INT;
-- Number of protects we are in syntactically, so that we
-- can pop out on a iterator quit, or a return.
readonly attr comp_home:STR;
-- The location of the SHOME variable in the generated Makefile.
-- This is different than prog.home if relative path names are used
private attr in_constant:BOOL;
-- true if the translated expression occurs in
-- constant initialization code (to bypass inlining)
private attr manual_unlock:BOOL;
-- true if the current code is in a lock statment that has to be manually
-- unlocked before leaving the function
private attr manual_loop_unlock:BOOL;
-- true if the current code is inside a lock statement that has to
-- be manually unlocked before leaving the lock.
attr threshold:INT; -- How big to make files before splitting up.
create(p:PROG):SAME is
res::=new;
res.prog:=p;-- CGEN::prog
LAYOUT_TBL::prog:=p;-- LAYOUT_TBL::prog
LAYOUT_TBL::cgen:=res;-- LAYOUT_TBL::cgen
res.threshold:=150_000; -- Default target size of 150KB per C file-- CGEN::threshold
return res;
-- Most initialization really occurs when "init" is called.
end;
init is
-- initialization should occur after the layouts and sigs have
-- been constructed
if only_check then return; end;-- CGEN::only_check
if prog.psather then type_tables:=true; end;-- CGEN::prog PROG::psather CGEN::type_tables
null_segfaults:=BOOL::from_str(prog.config.get_str("NULL_SEGFAULTS",0));-- CGEN::null_segfaults BOOL::from_str CGEN::prog PROG::config CONFIG_TBL::get_str
if force_all or ~force_routines.is_empty then-- CGEN::force_all CGEN::force_routines FSET{1}::is_empty BOOL::not
warning("-force options not implemented");-- CGEN::warning
end;
mangler:=#(prog);-- CGEN::mangler MANGLE::create CGEN::prog
-- mangle_force all builtin classes
d::=prog.config.get_def("BUILTIN_CLASSES");-- CGEN::prog PROG::config CONFIG_TBL::get_def
loop e::=d.elt!;-- CONFIG_DEF::elt!
loop
c::=e.elt!;-- ARRAY{1}::elt!
if c[0]='$' then-- STR::aget CHAR::is_eq
c:=c.tail(c.size-1);-- STR::tail STR::size INT::minus
end;
mangler.force_mangle(prog.tp_tbl.tp_class_for(#IDENT(e.elt!),void),c,void);-- CGEN::mangler MANGLE::force_mangle CGEN::prog PROG::tp_tbl TP_TBL::tp_class_for IDENT::create ARRAY{1}::elt!
end;
end;
op::=prog.get_options;-- CGEN::prog PROG::get_options
typecase op when CS_OPTIONS then options:=op; end;-- CGEN::options
genam::=prog.generate_am;-- CGEN::prog PROG::generate_am
typecase genam when GENERATE_AM then gen:=genam; end;-- CGEN::gen
nested_its:=#;-- CGEN::nested_its FMAP{2}::create
nested_bits:=#;-- CGEN::nested_bits FMAP{2}::create
abstract_routs:=#;-- CGEN::abstract_routs FLIST{1}::create
abstract_iters:=#;-- CGEN::abstract_iters FLIST{1}::create
not_emitted:=#;-- CGEN::not_emitted FMAP{2}::create
leftovers:=#;-- CGEN::leftovers FSET{1}::create
emitted_leftovers:=#;-- CGEN::emitted_leftovers FSET{1}::create
bnd_rout_creates:=#;-- CGEN::bnd_rout_creates FLIST{1}::create
bnd_iter_creates:=#; -- CGEN::bnd_iter_creates FLIST{1}::create
--frames:=#;
arg_frames:=#;-- CGEN::arg_frames FSET{1}::create
emitted_iter_allocators:=#;-- CGEN::emitted_iter_allocators FSET{1}::create
str_count:=1;-- CGEN::str_count
string_constants:=#;-- CGEN::string_constants FMAP{2}::create
--routs_with_frames:=#;
emitted_dispatch_wrappers:=#;-- CGEN::emitted_dispatch_wrappers FMAP{2}::create
code_files:=#;-- CGEN::code_files FMAP{2}::create
indent:=0;-- CGEN::indent
abstract_calls:=0;-- CGEN::abstract_calls
concrete_calls:=0;-- CGEN::concrete_calls
inlined_value_ob_eq_calls:=0;-- CGEN::inlined_value_ob_eq_calls
inlined_pointer_ob_eq_calls:=0;-- CGEN::inlined_pointer_ob_eq_calls
in_constant := false;-- CGEN::in_constant
code_dir:=executable+".code";-- CGEN::code_dir CGEN::executable STR::plus
CODE_FILE::set_directory(prog,code_dir);-- CODE_FILE::set_directory CGEN::prog CGEN::code_dir
--typedefs_h:=#CODE_FILE("typedefs.h");
sather_h:=#CODE_FILE("sather.h");-- CGEN::sather_h CODE_FILE::create
--decs_h:=#CODE_FILE("decs.h");
--globals_h:=#CODE_FILE("globals.h");
tags_h:=#CODE_FILE("tags.h");-- CGEN::tags_h CODE_FILE::create
makefile:=#CODE_FILE("Makefile");-- CGEN::makefile CODE_FILE::create
-- The system code is special; it doesn't bother with
-- the checking macros definitions.
system_c:=#CODE_FILE("system.c");-- CGEN::system_c CODE_FILE::create
code_files:=code_files.insert(TP_BUILTIN::sys,system_c);-- CGEN::code_files CGEN::code_files FMAP{2}::insert TP_BUILTIN::sys CGEN::system_c
system_c.is_c_code:=true;-- CGEN::system_c CODE_FILE::is_c_code
system_c.do_not_merge:=true;-- CGEN::system_c CODE_FILE::do_not_merge
globals_c:=#CODE_FILE("globals.c");-- CGEN::globals_c CODE_FILE::create
globals_c.is_c_code:=true;-- CGEN::globals_c CODE_FILE::is_c_code
globals_c.do_not_merge:=true;-- CGEN::globals_c CODE_FILE::do_not_merge
strings_c:=#CODE_FILE("strings.c");-- CGEN::strings_c CODE_FILE::create
strings_c.is_c_code:=true;-- CGEN::strings_c CODE_FILE::is_c_code
strings_c.do_not_merge:=true;-- CGEN::strings_c CODE_FILE::do_not_merge
dispatch_c:=#CODE_FILE("dispatch.c");-- CGEN::dispatch_c CODE_FILE::create
dispatch_c.is_c_code:=true;-- CGEN::dispatch_c CODE_FILE::is_c_code
unbox_c:=#CODE_FILE("unbox.c");-- CGEN::unbox_c CODE_FILE::create
unbox_c.is_c_code:=true;-- CGEN::unbox_c CODE_FILE::is_c_code
if print_ob or print_ob_g then unbox_c+"#define FF (*pFF)\n"; end;-- CGEN::print_ob CGEN::print_ob_g CGEN::unbox_c CODE_FILE::plus
comp_home:=prog.home;-- CGEN::comp_home CGEN::prog PROG::home
if comp_home[0]/='/' then comp_home:="../"+comp_home; end; -- CGEN::comp_home STR::aget CHAR::is_eq BOOL::not CGEN::comp_home CGEN::comp_home
sather_h+"#ifndef _SATHER_H_\n#define _SATHER_H_\n";-- CGEN::sather_h CODE_FILE::plus
if print_ob or print_ob_g then sather_h+"#define PRINT_PO\n"; end;-- CGEN::print_ob CGEN::print_ob_g CGEN::sather_h CODE_FILE::plus
if print_ob_g then sather_h+"#define PRINT_POG\n"; end;-- CGEN::print_ob_g CGEN::sather_h CODE_FILE::plus
if deterministic then sather_h+"#define DETERMINISTIC\n"; end;-- CGEN::deterministic CGEN::sather_h CODE_FILE::plus
if debug then sather_h+"#define DEBUG\n"; end;-- CGEN::debug CGEN::sather_h CODE_FILE::plus
if options.destroy_chk then sather_h+"#define DESTROY_CHK\n"; end;-- CGEN::options CS_OPTIONS::destroy_chk CGEN::sather_h CODE_FILE::plus
if null_segfaults then sather_h+"#define NULL_SEGFAULTS\n"; end;-- CGEN::null_segfaults CGEN::sather_h CODE_FILE::plus
if options.stats then sather_h+"#define STATS\n"; end;-- CGEN::options CS_OPTIONS::stats CGEN::sather_h CODE_FILE::plus
if options.cache then -- CGEN::options CS_OPTIONS::cache
sather_h+"#define IMPORT_CACHE\n"+-- CGEN::sather_h CODE_FILE::plus
"#define IMPORT_CACHE_SIZE "+options.cache_size+"\n"+-- CODE_FILE::plus CGEN::options CS_OPTIONS::cache_size CODE_FILE::plus
"#define IMPORT_CACHE_TRESHOLD "+options.cache_slot_size+"\n";-- CODE_FILE::plus CGEN::options CS_OPTIONS::cache_slot_size CODE_FILE::plus
end;
sather_h+"#include \""+comp_home+"/System/Common/header.h\"\n";-- CGEN::sather_h CODE_FILE::plus CGEN::comp_home CODE_FILE::plus
loop
n::=prog.platforms.elt!;-- CGEN::prog PROG::platforms FLIST{1}::elt!
if n[0]/='/' then n:="../"+n; end;-- STR::aget CHAR::is_eq BOOL::not STR::plus
sather_h+"#include \""+n+"/header.h\"\n";-- CGEN::sather_h CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
sather_h+"#endif\n";-- CGEN::sather_h CODE_FILE::plus
needs_tag:=#;-- CGEN::needs_tag FSET{1}::create
tags:=#;-- CGEN::tags FMAP{2}::create
--neg_tag_count:=1;
--pos_tag_count:=1;
main_sig:=prog.get_main_sig.main_sig;-- CGEN::main_sig CGEN::prog PROG::get_main_sig
end;
-- iter_frame return "frame->" if current_sig.is_iter, "" otherwise
iter_frame:STR is
if current_sig.is_iter then-- CGEN::current_sig SIG::is_iter
return "frame->";
else
return "";
end;
end;
-- mangling is all done by the mangler. The common uses are delegated
-- here, with a single shared namespace associated with the back-end
-- itself by default.
private mang(ob:$OB):STR is
return mangler.mangle(ob,void);-- CGEN::mangler MANGLE::mangle
end;
private mang(ob,ns:$OB):STR is
return mangler.mangle(ob,ns);-- CGEN::mangler MANGLE::mangle
end;
builtin_cntr:INT is
builtin_cntr_n:=builtin_cntr_n+1;-- CGEN::builtin_cntr_n CGEN::builtin_cntr_n INT::plus
return builtin_cntr_n;-- CGEN::builtin_cntr_n
end;
private forbid(s:STR) is mangler.forbid(s); end;-- CGEN::mangler MANGLE::forbid
-- Because local variables have to precede any use, it is necessary to
-- queue up code until all the locals that will be needed have been
-- discovered. This is done by using the following calls.
private in is indent:=indent+1; end;-- CGEN::indent CGEN::indent INT::plus
-- move indentation in a logical level
private move_out is indent:=indent-1; end;-- CGEN::indent CGEN::indent INT::minus
-- move indentation out a logical level
private defer_newline is -- start a new line in queued-up code
routine_code:=routine_code+eol;-- CGEN::routine_code CGEN::routine_code CGEN::eol
loop indent.times!; routine_code:=routine_code+' '; end;-- CGEN::indent INT::times! CGEN::routine_code CGEN::routine_code FSTR::plus
end;
private newline is code_c+eol; loop indent.times!; code_c+' '; end; end;-- CGEN::code_c CGEN::eol CGEN::indent INT::times! CGEN::code_c CODE_FILE::plus
-- start a new line to code file
private attr last_lineno:INT;
private attr last_file:STR;
private announce_at(s:SFILE_ID) is
if debug or pretty then-- CGEN::debug CGEN::pretty
-- terminate current C line and emit #line directive
lineno:INT:=s.line_num_in;-- SFILE_ID::line_num_in
if lineno>0 then-- INT::is_lt
prog.set_eloc(s);-- CGEN::prog PROG::set_eloc
if lineno=last_lineno+1 and last_file=s.file_in then-- CGEN::last_lineno INT::plus CGEN::last_file STR::is_eq SFILE_ID::file_in
if pretty then -- CGEN::pretty
routine_code:=routine_code+"\n/* #line "+lineno+" "-- CGEN::routine_code CGEN::routine_code FSTR::plus FSTR::plus
+" \""+s.file_in+"\"*/\n";-- FSTR::plus FSTR::plus FSTR::plus SFILE_ID::file_in FSTR::plus
else
routine_code:=routine_code+'\n';-- CGEN::routine_code CGEN::routine_code FSTR::plus
end;
elsif lineno=last_lineno and last_file=s.file_in then-- CGEN::last_lineno CGEN::last_file STR::is_eq SFILE_ID::file_in
-- do nothing
else
if debug then-- CGEN::debug
routine_code:=routine_code+"\n#line "+lineno+" "-- CGEN::routine_code CGEN::routine_code FSTR::plus FSTR::plus
+" \""+s.file_in+"\"\n";-- FSTR::plus FSTR::plus FSTR::plus SFILE_ID::file_in FSTR::plus
else
routine_code:=routine_code+"\n/* #line "+lineno+" "-- CGEN::routine_code CGEN::routine_code FSTR::plus FSTR::plus
+" \""+s.file_in+"\"*/\n";-- FSTR::plus FSTR::plus FSTR::plus SFILE_ID::file_in FSTR::plus
end;
end;
last_lineno:=lineno;-- CGEN::last_lineno
last_file:=s.file_in;-- CGEN::last_file SFILE_ID::file_in
end;
end;
end;
private eol:STR is
-- generate a newline or backslash newline, depending on whether
-- or not debugging #line directives are happening.
-- For some reason, backslash-newline doesn't seem to work. So
-- I've taken them out :-(
if debug then-- CGEN::debug
if pretty then return "\n#line "+last_lineno+"\n";-- CGEN::pretty CGEN::last_lineno STR::plus
else return "";
end;
else return "\n";
end;
end;
private defer(s:STR) is routine_code:=routine_code+s; end;-- CGEN::routine_code CGEN::routine_code FSTR::plus
-- queue up code for emmission
private ndefer(s:STR) is defer_newline; routine_code:=routine_code+s; end;-- CGEN::defer_newline CGEN::routine_code CGEN::routine_code FSTR::plus
-- same as defer but emits preceding newline
private comment(f:CODE_FILE,com:STR) is
-- make a C comment
if pretty then f+" /* "+com+" */"; end;-- CGEN::pretty CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
private comment(com:STR) is
-- make C comment in routine_code. Has newline.
if pretty then ndefer("/* "+com+" */"); end;-- CGEN::pretty CGEN::ndefer STR::plus STR::plus
end;
private dec_local(t:$TP):STR is
-- declare local with no comment
res::=mangler.genlocal(current_sig);-- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(t)+' '+res+';';-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
return res;
end;
private dec_local_for_arg(a:AM_FORMAL_ARG, sig:SIG, s:STR): STR is
-- declare local of type a.tp initialized to s
-- To be used instead of arg in out/inout args
res::=mangler.space(sig).next_unique_with_prefix("L");-- CGEN::mangler MANGLE::space NAMESPACE::next_unique_with_prefix
-- force the mangling of the argument expr
mangler.force_mangle(a.expr, res, sig);-- CGEN::mangler MANGLE::force_mangle AM_FORMAL_ARG::expr
code_c+eol+' '+mang(a.tp)+' '+res+" = " + s + ';' + "/*Local for arg*/";-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_FORMAL_ARG::tp CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
return res;
end;
private dec_local_object(t:$TP):STR
-- declare local object (not reference) of reference type t
-- used in implementation of out/inout arguments
is
res::=mangler.genlocal(current_sig);
code_c+eol+' '+mang(t)+"_struct "+res+';';
return res;
end;
private dec_local_ptr(t:$TP):STR is
-- declare local pointer to type t
-- used in implementation of out/inout arguments
res::=mangler.genlocal(current_sig);-- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(t)+"* "+res+';';-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
return res;
end;
private dec_local_comment(t:$TP,com:STR):STR is
res::=dec_local(t);-- CGEN::dec_local
comment(code_c,com);-- CGEN::code_c
return res;
end;
am_ob_def_for_tp(tp:$TP):AM_OB_DEF is
-- The object layout for the type `tp'.
impl::=tp.impl;
if void(impl) then return void end;
r::=#AM_OB_DEF(void);-- AM_OB_DEF::create
r.tp:=impl.tp;-- AM_OB_DEF::tp IMPL::tp
if ~void(impl.arr) then a::=impl.arr;-- IMPL::arr BOOL::not IMPL::arr
typecase a when TP_CLASS then r.arr:=a.params[0] end end;-- AM_OB_DEF::arr TP_CLASS::params ARRAY{1}::aget
r.asize:=impl.asize_val;-- AM_OB_DEF::asize IMPL::asize_val
loop e::=impl.elts.elt!; -- IMPL::elts ELT_TBL::elt!
if e.is_attr_reader then -- ELT::is_attr_reader
r.at:=r.at.insert(e.sig.name,e.sig.ret)-- AM_OB_DEF::at AM_OB_DEF::at FMAP{2}::insert ELT::sig SIG::name ELT::sig SIG::ret
end;
end;
return r;
end;
private set_chks is
-- set checking states for this function
n::=current_sig.tp.str;-- CGEN::current_sig SIG::tp
chk_pre:=options.pre_chk(n);-- CGEN::chk_pre CGEN::options CS_OPTIONS::pre_chk
chk_post:=options.post_chk(n);-- CGEN::chk_post CGEN::options CS_OPTIONS::post_chk
chk_invariant:=options.invariant_chk(n);-- CGEN::chk_invariant CGEN::options CS_OPTIONS::invariant_chk
chk_assert:=options.assert_chk(n);-- CGEN::chk_assert CGEN::options CS_OPTIONS::assert_chk
chk_arith:=options.arith_chk(n);-- CGEN::chk_arith CGEN::options CS_OPTIONS::arith_chk
chk_bounds:=options.bounds_chk(n);-- CGEN::chk_bounds CGEN::options CS_OPTIONS::bounds_chk
chk_void:=options.void_chk(n);-- CGEN::chk_void CGEN::options CS_OPTIONS::void_chk
chk_when:=options.when_chk(n);-- CGEN::chk_when CGEN::options CS_OPTIONS::when_chk
chk_return:=options.return_chk(n);-- CGEN::chk_return CGEN::options CS_OPTIONS::return_chk
end;
emit(func:AM_ROUT_DEF) is
announce_at(func.source);-- CGEN::announce_at AM_ROUT_DEF::source
if only_check then return; end;-- CGEN::only_check
if prog.show_am then #OUT+"Generating C for "+func.sig.str+'\n'; end;-- CGEN::prog PROG::show_am OUT::create OUT::plus OUT::plus AM_ROUT_DEF::sig SIG::str OUT::plus
if func.sig=main_sig then-- AM_ROUT_DEF::sig CGEN::main_sig
mangler.force_mangle(func.sig,"sather_main",void);-- CGEN::mangler MANGLE::force_mangle AM_ROUT_DEF::sig
system_c.uses_sig(func.sig);-- CGEN::system_c CODE_FILE::uses_sig AM_ROUT_DEF::sig
end;
if func.is_abstract then-- AM_ROUT_DEF::is_abstract
if ~func.is_iter then-- AM_ROUT_DEF::is_iter BOOL::not
abstract_routs:=abstract_routs.push(func);-- CGEN::abstract_routs CGEN::abstract_routs FLIST{1}::push
else
abstract_iters := abstract_iters.push(func); -- CGEN::abstract_iters CGEN::abstract_iters FLIST{1}::push
end
else
-- Ivin: do emit code for inlined recursive functions.
if prog.inliner.inlined(func.sig) and-- CGEN::prog PROG::inliner AM_ROUT_DEF::sig
~prog.generate_am.sig_recursive.test(func.sig) then-- CGEN::prog PROG::generate_am FSET{1}::test AM_ROUT_DEF::sig BOOL::not
not_emitted:=not_emitted.insert(func.sig,func);-- CGEN::not_emitted CGEN::not_emitted FMAP{2}::insert AM_ROUT_DEF::sig
-- it's inline, so don't bother generating it now;
-- it will get generated if used in a dispatch table or as biter
-- registery needed to retrieve am_rout_defs of iters from their
-- signatures, whenever they have been inlined, note a similar map
-- exists, namely not_emitted, it cannot be used since it is used
-- jointly with leftovers, see make_sure_emitted and generate_bnd_iter
-- map is also used in emit_am_bnd_iter_create, to store itersigs
-- for later use
if func.sig.is_iter then-- AM_ROUT_DEF::sig SIG::is_iter
itersig_map := itersig_map.insert(func.sig,func); end;-- CGEN::itersig_map CGEN::itersig_map FMAP{2}::insert AM_ROUT_DEF::sig
elsif ~func.sig.is_builtin_routine then-- AM_ROUT_DEF::sig SIG::is_builtin_routine BOOL::not
emit_routine(func);-- CGEN::emit_routine
end;
end;
end;
private code_file_for_tp(t:$TP):CODE_FILE is
cc::=code_files.get(t);-- CGEN::code_files FMAP{2}::get
if void(cc) then
cc:=#CODE_FILE(mang(t)+".c");-- CODE_FILE::create CGEN::mang STR::plus
cc.chk_pre:=chk_pre;-- CODE_FILE::chk_pre CGEN::chk_pre
cc.chk_post:=chk_post;-- CODE_FILE::chk_post CGEN::chk_post
cc.chk_invariant:=chk_invariant;-- CODE_FILE::chk_invariant CGEN::chk_invariant
cc.chk_return:=chk_return;-- CODE_FILE::chk_return CGEN::chk_return
cc.chk_when:=chk_when;-- CODE_FILE::chk_when CGEN::chk_when
cc.chk_arith:=chk_arith;-- CODE_FILE::chk_arith CGEN::chk_arith
cc.chk_assert:=chk_assert;-- CODE_FILE::chk_assert CGEN::chk_assert
cc.chk_bounds:=chk_bounds;-- CODE_FILE::chk_bounds CGEN::chk_bounds
cc.chk_void:=chk_void;-- CODE_FILE::chk_void CGEN::chk_void
cc.is_c_code:=true;-- CODE_FILE::is_c_code
-- esc: the output will be sorted alphabetically,
-- with breakpoints set at the 'good_place_to_split' positions.
-- therefore, this doesn't quite make sense.
-- (it will be moved almost to the end of the C file.)
--cc+"\n\n/* C for type "+mang(t)+" */\n\n";
code_files:=code_files.insert(t,cc);-- CGEN::code_files CGEN::code_files FMAP{2}::insert
end;
return cc;
end;
private setup_routine(func:AM_ROUT_DEF) is
current_sig:=func.sig;-- CGEN::current_sig AM_ROUT_DEF::sig
current_am_rout_def:=func;-- CGEN::current_am_rout_def
current_function_str:=func.sig.str;-- CGEN::current_function_str AM_ROUT_DEF::sig SIG::str
set_chks;-- CGEN::set_chks
code_c:=code_file_for_tp(current_sig.tp);-- CGEN::code_c CGEN::current_sig SIG::tp
if func.sig.is_iter then -- AM_ROUT_DEF::sig SIG::is_iter
nested_its:=nested_its.insert(func,#FLIST{AM_ITER_CALL_EXPR}(5));-- CGEN::nested_its CGEN::nested_its FMAP{2}::insert FLIST{1}::create
-- that 5 is important - it keeps it from being void()
nested_bits:=nested_bits.insert(func,#FLIST{AM_BND_ITER_CALL_EXPR}(5));-- CGEN::nested_bits CGEN::nested_bits FMAP{2}::insert FLIST{1}::create
-- that 5 is important - it keeps it from being void(),
-- this non void business is important, since we need it in emit_am_loop
-- to check for nested calls
end;
routine_code:=#FSTR;-- CGEN::routine_code FSTR::create
end;
private create_iter(func:AM_ROUT_DEF)
is
func.num_yields:=1;-- AM_ROUT_DEF::num_yields
it::=#AM_ITER_CALL_EXPR(func.size,func.source);-- AM_ITER_CALL_EXPR::create AM_ROUT_DEF::size AM_ROUT_DEF::source
it.fun:=func.sig;-- AM_ITER_CALL_EXPR::fun AM_ROUT_DEF::sig
lp::=#AM_LOOP_STMT(func.source);-- AM_LOOP_STMT::create AM_ROUT_DEF::source
func.calls:=func.calls.push(it);-- AM_ROUT_DEF::calls AM_ROUT_DEF::calls FLIST{1}::push
lp.its:=lp.its.push(it);-- AM_LOOP_STMT::its AM_LOOP_STMT::its FLIST{1}::push
lp.has_yield:=true;-- AM_LOOP_STMT::has_yield
it.lp:=lp;-- AM_ITER_CALL_EXPR::lp
it.init_before_loop:=true;-- AM_ITER_CALL_EXPR::init_before_loop
it.uniq:="I_u_I";-- AM_ITER_CALL_EXPR::uniq
loop
i::=it.ind!;-- AM_ITER_CALL_EXPR::ind!
it[i]:=#AM_CALL_ARG(func[i].expr,func[i].mode);-- AM_ITER_CALL_EXPR::aset AM_CALL_ARG::create AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_ROUT_DEF::aget AM_FORMAL_ARG::mode
end;
yl::=#AM_YIELD_STMT(func.source);-- AM_YIELD_STMT::create AM_ROUT_DEF::source
yl.ret:=1;-- AM_YIELD_STMT::ret
if func.sig.has_ret then-- AM_ROUT_DEF::sig SIG::has_ret
yl.val:=it;-- AM_YIELD_STMT::val
lp.body:=yl;-- AM_LOOP_STMT::body
else
st::=#AM_EXPR_STMT(func.source);-- AM_EXPR_STMT::create AM_ROUT_DEF::source
st.expr:=it;-- AM_EXPR_STMT::expr
st.next:=yl;-- AM_EXPR_STMT::next
lp.body:=st;-- AM_LOOP_STMT::body
end;
func.code:=lp;-- AM_ROUT_DEF::code
end;
private emit_routine(func:AM_ROUT_DEF) is
arg_list:ARRAY{STR};
ex_nesting:=0;-- CGEN::ex_nesting
manual_unlock:=false;-- CGEN::manual_unlock
manual_loop_unlock:=false;-- CGEN::manual_loop_unlock
if func.sig.is_builtin then-- AM_ROUT_DEF::sig SIG::is_builtin
if func.sig.is_iter then -- AM_ROUT_DEF::sig SIG::is_iter
create_iter(func);-- CGEN::create_iter
else return;
end;
end;
routine_count:=routine_count+1;-- CGEN::routine_count CGEN::routine_count INT::plus
setup_routine(func);-- CGEN::setup_routine
emit_prologue(func);-- CGEN::emit_prologue
emit_code(func.code);-- CGEN::emit_code AM_ROUT_DEF::code
emit_epilogue(func);-- CGEN::emit_epilogue
-- if an iter, do typedef with same name for holding the frame
if func.is_iter then-- AM_ROUT_DEF::is_iter
--frames:=frames.push(func);
code_c.here_is_iter(func);-- CGEN::code_c CODE_FILE::here_is_iter
code_c.uses_iter(func.sig);-- CGEN::code_c CODE_FILE::uses_iter AM_ROUT_DEF::sig
else
-- Try to make some garbage.
mangler.dispose_namespace(func.sig);-- CGEN::mangler MANGLE::dispose_namespace AM_ROUT_DEF::sig
end;
-- esc: this is a good place to split, isn't it?
code_c.good_place_to_split;-- CGEN::code_c CODE_FILE::good_place_to_split
end;
finalize is
-- finish up files, and call C compiler.
if only_check then return; end;-- CGEN::only_check
make_sure_emitted (main_sig); -- Ivin - prevent inlining main.-- CGEN::main_sig
define_main_and_globals;-- CGEN::define_main_and_globals
make_tag_table;-- CGEN::make_tag_table
-- there may be a circular dependency between leftover
-- routines and bound routine creations. That is emitting
-- code for a leftover routine may introduce more bound
-- routine creations, and emitting stubs for bound routines
-- may introduce more leftover routines. The loop bellow is
-- executed until both lists are empty simultaneously
-- Each leftover function may also produce some more
-- entries for the dispatch table, which in turn may create
-- more leftovers, and so on..... ( generate_dispathc...
-- adjusts the tag table too).
-- For bound routines we need to redefine FF
if print_ob or print_ob_g then system_c+"#define FF (*pFF)\n"; end;-- CGEN::print_ob CGEN::print_ob_g CGEN::system_c CODE_FILE::plus
loop
generate_bnd_rout_stubs;-- CGEN::generate_bnd_rout_stubs
generate_bnd_iter_stubs; -- CGEN::generate_bnd_iter_stubs
generate_leftovers;-- CGEN::generate_leftovers
generate_dispatch_rout_and_iters;-- CGEN::generate_dispatch_rout_and_iters
until!(leftovers.size=0 and bnd_rout_creates.is_empty and -- CGEN::leftovers FSET{1}::size INT::is_eq CGEN::bnd_rout_creates FLIST{1}::is_empty
bnd_iter_creates.is_empty);-- CGEN::bnd_iter_creates FLIST{1}::is_empty
end;
-- For bound routines we need to undefine FF here
if print_ob or print_ob_g then system_c+"#undef FF\n"; end;-- CGEN::print_ob CGEN::print_ob_g CGEN::system_c CODE_FILE::plus
-- Ivin: leftovers may introduce more tags.
generate_dispatch_tables;-- CGEN::generate_dispatch_tables
generate_sys_tables;-- CGEN::generate_sys_tables
if prog.prolix then-- CGEN::prog PROG::prolix
#OUT+"\nAbstract calls: "+abstract_calls;-- OUT::create OUT::plus CGEN::abstract_calls
#OUT+"\nConcrete calls: "+concrete_calls;-- OUT::create OUT::plus CGEN::concrete_calls
#OUT+"\nInlined value ob_eq calls: "+inlined_value_ob_eq_calls;-- OUT::create OUT::plus CGEN::inlined_value_ob_eq_calls
#OUT+"\nInlined pointer ob_eq calls: "+inlined_pointer_ob_eq_calls;-- OUT::create OUT::plus CGEN::inlined_pointer_ob_eq_calls
#OUT+"\nMarked read attr routs: "+INLINE_ATTR_READ::routines;-- OUT::create OUT::plus OUT::plus INLINE_ATTR_READ::routines
#OUT+"\nInlined read attr calls: "+INLINE_ATTR_READ::inlined;-- OUT::create OUT::plus OUT::plus INLINE_ATTR_READ::inlined
#OUT+"\nMarked write attr routs: "+INLINE_ATTR_WRITE::routines;-- OUT::create OUT::plus OUT::plus INLINE_ATTR_WRITE::routines
#OUT+"\nInlined write attr calls: "+INLINE_ATTR_WRITE::inlined;-- OUT::create OUT::plus OUT::plus INLINE_ATTR_WRITE::inlined
#OUT+"\nMarked global routs: "+INLINE_GLOBAL_READ::routines;-- OUT::create OUT::plus OUT::plus INLINE_GLOBAL_READ::routines
#OUT+"\nInlined global calls: "+INLINE_GLOBAL_READ::inlined;-- OUT::create OUT::plus OUT::plus INLINE_GLOBAL_READ::inlined
#OUT+"\nMarked INT routs: "+INLINE_INT_FOLD::routines;-- OUT::create OUT::plus OUT::plus INLINE_INT_FOLD::routines
#OUT+"\nFolded INT calls: "+INLINE_INT_FOLD::inlined;-- OUT::create OUT::plus OUT::plus INLINE_INT_FOLD::inlined
#OUT+"\nMarked short routs: "+INLINE_ROUT::routines;-- OUT::create OUT::plus OUT::plus INLINE_ROUT::routines
#OUT+"\nInlined short rout calls: "+INLINE_ROUT::inlined;-- OUT::create OUT::plus OUT::plus INLINE_ROUT::inlined
#OUT+"\nMarked flat iters: "+INLINE_ITER::iters;-- OUT::create OUT::plus OUT::plus INLINE_ITER::iters
#OUT+"\nInlined flat iter calls: "+INLINE_ITER::inlined;-- OUT::create OUT::plus OUT::plus INLINE_ITER::inlined
#OUT+"\nInlined builtin iter calls: "+inlined_iter_count+"\n\n";-- OUT::create OUT::plus CGEN::inlined_iter_count OUT::plus
if ~void(prog.itercounts) then-- CGEN::prog PROG::itercounts BOOL::not
#OUT+"\nThe following do not include break!, while! or until!.\n";-- OUT::create OUT::plus
#OUT+"\nIters:\tIters\t# loops\n";-- OUT::create OUT::plus
loop
i::=0.upto!(9);-- INT::upto!
ct::=prog.itercounts[i];-- CGEN::prog PROG::itercounts ARRAY{1}::aget
while!(ct>0);-- INT::is_lt
#OUT+'\t'+i+'\t'+ct+'\n';-- OUT::create OUT::plus OUT::plus OUT::plus OUT::plus OUT::plus
end;
#OUT+"\n\nHots:\tIters\t# loops\n";-- OUT::create OUT::plus
loop
i::=0.upto!(9);-- INT::upto!
ct::=prog.hotcounts[i];-- CGEN::prog PROG::hotcounts ARRAY{1}::aget
while!(ct>0);-- INT::is_lt
#OUT+'\t'+i+'\t'+ct+'\n';-- OUT::create OUT::plus OUT::plus OUT::plus OUT::plus OUT::plus
end;
end;
end;
allflags::=prog.config.get_str("CC_OPTIONS",0);-- CGEN::prog PROG::config CONFIG_TBL::get_str
libs ::= "";
-- I moved the processing of the default flag before
-- the processing of user defined flags (comming from
-- -C_flag). This way the user can overwrite the default
-- flags, for example with -O2. CMF
allflags:=allflags+"-I. ";-- STR::plus
if debug then-- CGEN::debug
allflags:=allflags+' '+prog.config.get_str("CC_DEBUG_FLAG",1);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
else
allflags:=allflags+' '+prog.config.get_str("CC_DEBUG_FLAG",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
end;
if optimize then-- CGEN::optimize
allflags:=allflags+' '+prog.config.get_str("CC_OPTIMIZE_FLAG",1);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
else
allflags:=allflags+' '+prog.config.get_str("CC_OPTIMIZE_FLAG",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
end;
if prog.prolix then-- CGEN::prog PROG::prolix
allflags:=allflags+' '+prog.config.get_str("CC_PROLIX_FLAG",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
else
allflags:=allflags+' '+prog.config.get_str("CC_PROLIX_FLAG",1);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
end;
loop
flag::=c_flags.elt!;-- CGEN::c_flags FLIST{1}::elt!
if flag.size>2 and flag.head(2)="-l" then libs:=libs+' '+flag;-- STR::size INT::is_lt STR::head STR::is_eq STR::plus STR::plus
else allflags:=allflags+' '+flag;-- STR::plus STR::plus
end; -- if
end;
libs:=libs+" "+prog.config.get_str("LINK_OPTIONS",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
if prog.psather then-- CGEN::prog PROG::psather
if options.psather_chk then allflags:=allflags+" -DPSATHER_CHK"; end;-- CGEN::options CS_OPTIONS::psather_chk STR::plus
if options.psather_stats then -- CGEN::options CS_OPTIONS::psather_stats
allflags:=allflags+" -DPSATHER_STATISTICS"; -- STR::plus
end;
if options.psather_trace then -- CGEN::options CS_OPTIONS::psather_trace
allflags:=allflags+" -DPSATHER_TRACE\n"; -- STR::plus
end;
end;
obfiles::=CODE_FILE::merge;-- CODE_FILE::merge
syscom::="$(CC) $(CFLAGS) ";
syscom:=syscom+prog.config.get_str("EXEC_OPTION",0)+"../$(CS) $(OBJ)";-- CGEN::prog PROG::config CONFIG_TBL::get_str STR::plus
if print_ob or print_ob_g then syscom:=syscom+" print"+prog.config.get_str("OBJECT_EXT",0); end;-- CGEN::print_ob CGEN::print_ob_g STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
other::="";
loop
s: STR := c_files.elt!.replace_suffix(prog.config.get_str("C_EXT",0),-- CGEN::c_files FSET{1}::elt! STR::replace_suffix CGEN::prog PROG::config CONFIG_TBL::get_str
prog.config.get_str("OBJECT_EXT",0));-- CGEN::prog PROG::config CONFIG_TBL::get_str
obfiles:=obfiles+' '+s.substring(s.search_backwards('/')+1);-- STR::plus STR::plus STR::substring STR::search_backwards INT::plus
end;
loop
s: STR := object_files.elt!;-- CGEN::object_files FSET{1}::elt!
if s[0] = '/' then other:=other+' '+s;-- STR::aget CHAR::is_eq STR::plus STR::plus
else
if s[0] = '-' then-- STR::aget CHAR::is_eq
other := other + s;-- STR::plus
else
other:=other+' '+"../"+s;-- STR::plus STR::plus STR::plus
end;
end; -- if
end;
-- Add any files needed by external classes
loop
cl::=prog.tp_tbl.class_tbl.elt!;-- CGEN::prog PROG::tp_tbl TP_TBL::class_tbl TP_CLASS_TBL::elt!
files::=externals.get(cl.str);-- CGEN::externals FMAP{2}::get TP_CLASS::str
if ~void(files) then-- BOOL::not
loop
file::=files.elt!;-- FSET{1}::elt!
if prog.prolix then-- CGEN::prog PROG::prolix
#OUT +"Including "+file+"; "+cl+" was reached\n";-- OUT::create OUT::plus OUT::plus OUT::plus OUT::plus OUT::plus
end;
if file[0] = '/' then other:=other+' '+file;-- STR::aget CHAR::is_eq STR::plus STR::plus
else
if file[0] = '-' then-- STR::aget CHAR::is_eq
other := other + file;-- STR::plus
else
other:=other+' '+"../"+file;-- STR::plus STR::plus STR::plus
end;
end;
end;
end;
end;
loop
s: STR := archive_files.elt!;-- CGEN::archive_files FLIST{1}::elt!
if s[0] = '/' then other:=other+' '+s;-- STR::aget CHAR::is_eq STR::plus STR::plus
else other:=other+' '+"../"+s;-- STR::plus STR::plus STR::plus
end; -- if
end;
syscom:=syscom+" $(OTHER)";-- STR::plus
syscom := syscom + " $(LIBS)";-- STR::plus
-- compute exec file name (no path)
exec_name:STR;
index: INT;
suffix_length::=0;
loop
i::=(executable.size-1).downto!(0);-- CGEN::executable STR::size INT::minus INT::downto!
if executable[i] = '/' then-- CGEN::executable STR::aget CHAR::is_eq
break!;
end;
suffix_length := suffix_length + 1;-- INT::plus
end;
exec_name := executable.tail(suffix_length);-- CGEN::executable STR::tail
makefile+"SHOME= "+comp_home+'\n';-- CGEN::makefile CODE_FILE::plus CGEN::comp_home CODE_FILE::plus
makefile+"CFLAGS= "+allflags+'\n';-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
makefile+"LIBS= " + libs + '\n';-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
makefile+"CS= "+exec_name+'\n';-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
makefile+"CC= "+prog.config.get_str("C_COMPILER",0)+'\n';-- CGEN::makefile CODE_FILE::plus CGEN::prog PROG::config CONFIG_TBL::get_str CODE_FILE::plus
makefile+"OBJ= "+obfiles+'\n';-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
makefile+"OTHER= "+other+'\n';-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
makefile+"HDR= *.h Makefile";-- CGEN::makefile CODE_FILE::plus
makefile+"\n\n../$(CS): $(OBJ) $(HDR)"; -- CGEN::makefile CODE_FILE::plus
if print_ob or print_ob_g then makefile+" print"+prog.config.get_str("OBJECT_EXT",0); end;-- CGEN::print_ob CGEN::print_ob_g CGEN::makefile CODE_FILE::plus CGEN::prog PROG::config CONFIG_TBL::get_str
makefile+"\n\t"+syscom+"\n\n";-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if print_ob or print_ob_g then-- CGEN::print_ob CGEN::print_ob_g
makefile+"print"+prog.config.get_str("OBJECT_EXT",0)+": $(HDR)\n";-- CGEN::makefile CODE_FILE::plus CGEN::prog PROG::config CONFIG_TBL::get_str CODE_FILE::plus
makefile+"\t$(CC) $(CFLAGS) -c -I. $(SHOME)/System/Debug/print.c\n\n";-- CGEN::makefile CODE_FILE::plus
end;
makefile+"$(OBJ): $(HDR)\n";-- CGEN::makefile CODE_FILE::plus
loop
s: STR := c_files.elt!;-- CGEN::c_files FSET{1}::elt!
o::=s.replace_suffix(prog.config.get_str("C_EXT",0),prog.config.get_str("OBJECT_EXT",0));-- STR::replace_suffix CGEN::prog PROG::config CONFIG_TBL::get_str CGEN::prog PROG::config CONFIG_TBL::get_str
o:=o.substring(o.search_backwards('/')+1);-- STR::substring STR::search_backwards INT::plus
if s[0]/='/' then s:="../"+s; end;-- STR::aget CHAR::is_eq BOOL::not STR::plus
makefile+"\n"+o+": "+s+" $(HDR)\n\t$(CC) $(CFLAGS) -c "+s+"\n";-- CGEN::makefile CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
makefile+"\n.c.o:; $(CC) $(CFLAGS) -c $*.c\n";-- CGEN::makefile CODE_FILE::plus
-- Write out any files which have changed, including the Makefile.
CODE_FILE::finalize;-- CODE_FILE::finalize
syscom:="cd "+code_dir+prog.config.get_str("SHELL_SEP",0)+" "+prog.config.get_str("MAKE_COMMAND",0);-- CGEN::code_dir CGEN::prog PROG::config CONFIG_TBL::get_str STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
if prog.verbose then-- CGEN::prog PROG::verbose
syscom:=syscom+' '+prog.config.get_str("MAKE_VERBOSE_FLAG",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
else
syscom:=syscom+' '+prog.config.get_str("MAKE_VERBOSE_FLAG",0);-- STR::plus CGEN::prog PROG::config CONFIG_TBL::get_str
end;
if only_C then-- CGEN::only_C
if prog.prolix then #OUT + "\nSkipping make.\n"; end;-- CGEN::prog PROG::prolix OUT::create OUT::plus
else
if prog.prolix then #OUT+'\n'+syscom+'\n'; end;-- CGEN::prog PROG::prolix OUT::create OUT::plus OUT::plus OUT::plus
if UNIX::system(syscom)/=0 then barf("Make failed."); end;-- UNIX::system INT::is_eq BOOL::not CGEN::barf
end;
if ~gen_c then -- CGEN::gen_c BOOL::not
-- This is a quick hack which should be replaced!
dummy::=UNIX::system("rm -fr "+code_dir);-- UNIX::system CGEN::code_dir
end;
-- Attempt to make garbage
SYS::destroy(self);-- SYS::destroy
end;
private cast(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL):STR is
return do_cast(dest_tp, src_tp, expr, only_boxing, void);-- CGEN::do_cast
end;
private cast_arg(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL, mode:$MODE):STR is
return do_cast(dest_tp, src_tp, expr, only_boxing, mode);-- CGEN::do_cast
end;
private do_cast(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL, mode:$MODE):STR
-- pre dest_tp=src_tp -- make sure cast isn't nonsense
-- or (dest_tp.is_abstract and src_tp.is_abstract)
-- or dest_tp.is_subtype(src_tp)
-- or src_tp.is_subtype(dest_tp)
is
if ~ (dest_tp=src_tp -- make sure cast isn't nonsense
or (dest_tp.is_abstract and src_tp.is_abstract)
or dest_tp.is_subtype(src_tp)
or src_tp.is_subtype(dest_tp)) then-- BOOL::not
#OUT+"CASTING ERROR: \n";-- OUT::create OUT::plus
#OUT+" dest_tp=";if void(dest_tp) then #OUT+"(void)"; else #OUT+dest_tp.str;end;-- OUT::create OUT::plus OUT::create OUT::plus OUT::create OUT::plus
#OUT+"\n src_tp=";if void(src_tp) then #OUT+"(void)"; else #OUT+src_tp.str;end;-- OUT::create OUT::plus OUT::create OUT::plus OUT::create OUT::plus
#OUT+"\n expr="+expr+"\n";-- OUT::create OUT::plus OUT::plus OUT::plus
UNIX::exit(1);-- UNIX::exit
end;
-- possibly convert an expression to another type to sooth C's
-- savage type beast when up- or down-typing.
code_c.uses_tp(dest_tp);-- CGEN::code_c CODE_FILE::uses_tp
--code_c.uses_tp(src_tp);
res:STR;
if dest_tp=src_tp then
res:=expr;
elsif dest_tp.is_abstract and
(src_tp.is_immutable or src_tp=TP_BUILTIN::ext_ob) then-- TP_BUILTIN::ext_ob
-- boxing
res:=dec_local_comment(dest_tp,"local for boxed "+src_tp.str);-- CGEN::dec_local_comment STR::plus
ndefer(res+" = ("+mang(dest_tp)+")"+allocate(src_tp)+";");-- CGEN::ndefer STR::plus STR::plus CGEN::mang STR::plus STR::plus CGEN::allocate STR::plus
ndefer("(("+mang(src_tp)+"_boxed) "-- CGEN::ndefer STR::plus CGEN::mang
+res+")->immutable_part = "+expr+";");-- STR::plus STR::plus STR::plus STR::plus STR::plus
elsif (dest_tp.is_immutable or dest_tp=TP_BUILTIN::ext_ob)-- TP_BUILTIN::ext_ob
and src_tp.is_abstract then
-- unboxing
res:=dec_local_comment(dest_tp,"local for unboxed "+src_tp.str);-- CGEN::dec_local_comment STR::plus
if prog.distributed then-- CGEN::prog PROG::distributed
if dest_tp.is_atomic then
ndefer("F_VA_RATTR_NN("+res+","+mang(dest_tp)+"_boxed,"+expr+",immutable_part);");-- CGEN::ndefer STR::plus STR::plus STR::plus CGEN::mang STR::plus STR::plus STR::plus
else
ndefer("F_V_RATTR_LL("+mang(dest_tp)+","+res+","+mang(dest_tp)+"_boxed,"+expr+",immutable_part);");-- CGEN::ndefer STR::plus CGEN::mang STR::plus STR::plus STR::plus STR::plus CGEN::mang STR::plus STR::plus STR::plus
ndefer("RECVOB("+tag_for(dest_tp)+",&"+res+",WHERE("+expr+"));");-- CGEN::ndefer STR::plus CGEN::tag_for STR::plus STR::plus STR::plus STR::plus STR::plus
end;
else
if dest_tp.is_atomic or ~prog.psather then-- CGEN::prog PROG::psather BOOL::not
ndefer(res+" = (("+mang(dest_tp)+"_boxed) "-- CGEN::ndefer STR::plus STR::plus CGEN::mang
+expr+")->immutable_part;");-- STR::plus STR::plus STR::plus
else
ndefer("VASS_LL("+res+","+mang(dest_tp)+",(("+mang(dest_tp)+"_boxed) "-- CGEN::ndefer STR::plus STR::plus STR::plus CGEN::mang STR::plus STR::plus CGEN::mang
+expr+")->immutable_part);");-- STR::plus STR::plus STR::plus
end;
end;
else
if ~only_boxing then -- BOOL::not
res:="(("+mang(dest_tp);-- STR::plus CGEN::mang
if ~void(mode) then-- BOOL::not
if (mode = MODES::out_mode) or (mode = MODES::inout_mode) or-- MODES::out_mode MODES::inout_mode
(dest_tp.kind = TP_KIND::ext_fortran_tp) then-- INT::is_eq TP_KIND::ext_fortran_tp
res := res + "*";-- STR::plus
end;
end;
res := res + ") " + expr+")";-- STR::plus STR::plus STR::plus
else
res:=expr;
end;
end;
return res;
end;
private sizeof(tp:$TP):STR is
-- an expression for the storage size of a given type.
if tp.is_immutable then return "sizeof("+mang(tp)+")";-- STR::plus CGEN::mang STR::plus
else return "sizeof(struct "+mang(tp)+"_struct)";-- STR::plus CGEN::mang STR::plus
end;
end;
private sizeof_boxed(tp:$TP):STR pre tp.is_immutable is
-- an expression for the size of a boxed value type
return "sizeof(struct "+mang(tp)+"_boxed_struct)";-- STR::plus CGEN::mang STR::plus
end;
private allocate(t:$TP):STR is
-- generate call which allocates memory and fills in tag for an
-- object of type t. This properly sets the tag field too. If
-- t is a value type it allocates the boxed version.
call_string:STR;
if t.is_reference_free then
call_string := "rt_alloc_atomic(";
else
call_string := "rt_alloc(";
end;
if t.is_immutable then
return "(("+mang(t)+"_boxed) "+call_string+sizeof_boxed(t)-- STR::plus CGEN::mang STR::plus STR::plus STR::plus CGEN::sizeof_boxed
+", "+tag_for(t)+"))";-- STR::plus STR::plus CGEN::tag_for STR::plus
elsif t=TP_BUILTIN::ext_ob then-- TP_BUILTIN::ext_ob
return "((EXT_OB_boxed) "+call_string+sizeof_boxed(t)-- STR::plus STR::plus CGEN::sizeof_boxed
+", "+tag_for(t)+"))";-- STR::plus STR::plus CGEN::tag_for STR::plus
else
return "(("+mang(t)+") "+call_string+sizeof(t)-- STR::plus CGEN::mang STR::plus STR::plus STR::plus CGEN::sizeof
+", "+tag_for(t)+"))";-- STR::plus STR::plus CGEN::tag_for STR::plus
end;
end;
private array_allocate(t:$TP,n:STR):STR is
-- generate call which allocates memory and fills in tag for an
-- object of type t and an array portion with n elements. This
-- sets the tag field but NOT asize, because it isn't reachable
-- from an untyped C routine. If t is a value type it allocates
-- the boxed version.
res,call_string:STR;
t2:$TP:=am_ob_def_for_tp(t).arr;-- CGEN::am_ob_def_for_tp AM_OB_DEF::arr
code_c.uses_tp(t2); -- Ivin.-- CGEN::code_c CODE_FILE::uses_tp
if t.is_reference_free then
call_string := "rt_arr_alloc_atomic(";
else
call_string := "rt_arr_alloc(";
end;
if t.is_immutable then
res:="(("+mang(t)+"_boxed) "+call_string+sizeof_boxed(t);-- STR::plus CGEN::mang STR::plus STR::plus STR::plus CGEN::sizeof_boxed
else res:="(("+mang(t)+") "+call_string+sizeof(t);-- STR::plus CGEN::mang STR::plus STR::plus STR::plus CGEN::sizeof
end;
res:=res+", "+tag_for(t)+", ";-- STR::plus STR::plus CGEN::tag_for STR::plus
code_c.uses_tp(t);-- CGEN::code_c CODE_FILE::uses_tp
code_c.uses_tp(t2);-- CGEN::code_c CODE_FILE::uses_tp
-- Use mang(t2) for the array portion, because we want the
-- same sizeof(x) expression whether or not it is a value type
return res+"sizeof("+mang(t2)+") , "+n+"))";-- STR::plus STR::plus CGEN::mang STR::plus STR::plus STR::plus
end;
private default_init(t:$TP):STR is
-- string representing default initialization expression
-- for a given type.
code_c.uses_tp(t);-- CGEN::code_c CODE_FILE::uses_tp
if t.is_immutable then
return mang(t)+"_zero";-- CGEN::mang STR::plus
else return "((".append(mang(t),") NULL)");-- STR::append CGEN::mang
end;
end;
private is_const_expr(e:$AM_EXPR):BOOL is
-- is this something we can make a C initializing constant for?
if void(e) then return false; end;
typecase e
when AM_VOID_CONST then return true;
when AM_BOOL_CONST then return true;
when AM_CHAR_CONST then return true;
when AM_STR_CONST then return true;
when AM_INT_CONST then return true;
else return false;
end;
end;
private define_main_and_globals is
-- generate actual main call, which then calls sather_main.
-- has to initialize any globals and declare them.
main_tp::=mang(main_sig.tp);-- CGEN::main_sig SIG::tp
code_c:=system_c;-- CGEN::code_c CGEN::system_c
system_c+'\n';-- CGEN::system_c CODE_FILE::plus
comment(system_c,"Definition of main (generated)");-- CGEN::system_c
system_c+"\nint main(int argc, char *argv[]) {";-- CGEN::system_c CODE_FILE::plus
if func_tables then-- CGEN::func_tables
system_c+"\n struct _func_frame FF={ 0,NULL,NULL };";-- CGEN::system_c CODE_FILE::plus
end;
routine_code:=#FSTR+"\n"; -- CGEN::routine_code FSTR::create FSTR::plus
in;-- CGEN::in
ndefer(main_tp+" main_ob;");-- CGEN::ndefer STR::plus
if ~void(main_sig.args) then-- CGEN::main_sig SIG::args BOOL::not
ndefer(mang(TP_BUILTIN::arr_of_str)+" main_args;");-- CGEN::ndefer CGEN::mang TP_BUILTIN::arr_of_str STR::plus
ndefer("int i,j,length;");-- CGEN::ndefer
ndefer("STR s;");-- CGEN::ndefer
end;
ndefer("int res=0;"); -- CGEN::ndefer
ndefer("sather_prog_name=argv[0];");-- CGEN::ndefer
if zones then ndefer("zinit_globals();"); end;-- CGEN::zones CGEN::ndefer
if prog.psather then ndefer("PSATHER_START(argv[0])");in; end;-- CGEN::prog PROG::psather CGEN::ndefer CGEN::in
-- emit globals and any initializing expressions needed
emit_globals;-- CGEN::emit_globals
code_c:=system_c;-- CGEN::code_c CGEN::system_c
-- default object for main
ndefer("main_ob = ");-- CGEN::ndefer
if main_sig.tp.is_immutable then defer(main_tp+"_zero;");-- CGEN::main_sig SIG::tp CGEN::defer STR::plus
else defer(allocate(main_sig.tp)+";");-- CGEN::defer CGEN::main_sig SIG::tp STR::plus
end;
-- arguments, if needed
if ~void(main_sig.args) then-- CGEN::main_sig SIG::args BOOL::not
ndefer("main_args = "
+array_allocate(TP_BUILTIN::arr_of_str,"argc")+";");-- CGEN::ndefer STR::plus CGEN::array_allocate TP_BUILTIN::arr_of_str STR::plus
ndefer("main_args->asize = argc;");-- CGEN::ndefer
ndefer("for (i=0;i<argc;i++) {");-- CGEN::ndefer
ndefer(" for (length=0; argv[i][length]!=0; length++);");-- CGEN::ndefer
ndefer(" s = "+array_allocate(TP_BUILTIN::str,"length")+";");-- CGEN::ndefer STR::plus CGEN::array_allocate TP_BUILTIN::str STR::plus
ndefer(" s->asize = length;");-- CGEN::ndefer
ndefer(" for (j=0;j<length;j++) s->arr_part[j] = argv[i][j];");-- CGEN::ndefer
ndefer(" main_args->arr_part[i] = s;");-- CGEN::ndefer
ndefer("}");-- CGEN::ndefer
end;
if null_segfaults then-- CGEN::null_segfaults
ndefer("signal(SIGSEGV,(void(*)(int))rt_segfault_handler);");-- CGEN::ndefer
end;
ndefer("rt_start(argv[0]);");-- CGEN::ndefer
ndefer("PROTECT_BEGIN");-- CGEN::ndefer
in;-- CGEN::in
f:STR:="";
if func_tables then f:=",NULL"; end;-- CGEN::func_tables
if ~void(main_sig.ret) then-- CGEN::main_sig SIG::ret BOOL::not
if ~void(main_sig.args) then-- CGEN::main_sig SIG::args BOOL::not
ndefer("res = sather_main(main_ob,main_args"+f+");");-- CGEN::ndefer STR::plus STR::plus
else ndefer("res = sather_main(main_ob"+f+");");-- CGEN::ndefer STR::plus STR::plus
end;
else
if ~void(main_sig.args) then-- CGEN::main_sig SIG::args BOOL::not
ndefer("sather_main(main_ob,main_args"+f+");");-- CGEN::ndefer STR::plus STR::plus
else ndefer("sather_main(main_ob"+f+");");-- CGEN::ndefer STR::plus STR::plus
end;
end;
ndefer("rt_stop();");-- CGEN::ndefer
move_out;-- CGEN::move_out
ndefer("PROTECT_WHEN");-- CGEN::ndefer
in;-- CGEN::in
code_c.uses_tp(TP_BUILTIN::str);-- CGEN::code_c CODE_FILE::uses_tp TP_BUILTIN::str
if prog.distributed then-- CGEN::prog PROG::distributed
ndefer("if(F_TAG(EXCEPTION)=="+tag_for(TP_BUILTIN::str) +") {");-- CGEN::ndefer STR::plus CGEN::tag_for TP_BUILTIN::str STR::plus
ndefer(" STR s;");-- CGEN::ndefer
ndefer(" s=(STR)rt_arr_alloc_atomic(sizeof(struct STR_struct),STR_tag,sizeof(CHAR),F_ASIZE(STR,EXCEPTION));");-- CGEN::ndefer
ndefer(" s->asize=F_ASIZE(STR,EXCEPTION);");-- CGEN::ndefer
ndefer(" F_R_ARRAY_OBJECT_NN(STR,CHAR,s,EXCEPTION);");-- CGEN::ndefer
ndefer(" fprintf(stderr,\"Uncaught STR exception: %s\\n\",s->arr_part);");-- CGEN::ndefer
ndefer("} else fprintf(stderr,\"Uncaught exception of type %s\\n\",gen_SYS_str_for_tp(F_TAG(EXCEPTION))->arr_part);");-- CGEN::ndefer
else
ndefer("if(TAG(EXCEPTION)=="+tag_for(TP_BUILTIN::str) +") {");-- CGEN::ndefer STR::plus CGEN::tag_for TP_BUILTIN::str STR::plus
ndefer(" fprintf(stderr,\"Uncaught STR exception: %s\\n\",((STR)EXCEPTION)->arr_part);");-- CGEN::ndefer
ndefer("} else fprintf(stderr,\"Uncaught exception of type %s\\n\",gen_SYS_str_for_tp(TAG(EXCEPTION))->arr_part);");-- CGEN::ndefer
end;
if prog.psather then-- CGEN::prog PROG::psather
ndefer("PSATHER_ABORT;");-- CGEN::ndefer
else
ndefer("abort();");-- CGEN::ndefer
end;
move_out;-- CGEN::move_out
--ndefer("}");
ndefer("PROTECT_END");-- CGEN::ndefer
if prog.psather then move_out;ndefer("PSATHER_STOP"); end;-- CGEN::prog PROG::psather CGEN::move_out CGEN::ndefer
ndefer("return res;"); -- CGEN::ndefer
move_out;-- CGEN::move_out
system_c+routine_code+"\n}\n\n";-- CGEN::system_c CGEN::routine_code CODE_FILE::plus
end;
private emit_globals is
-- emit declarations for globals and any code in main
-- that has to execute to initialize to them before other code
loop
age::=gen.global_tbl.top_sort.elt!;-- CGEN::gen GENERATE_AM::global_tbl GLOBAL_TBL::top_sort FLIST{1}::elt!
globals_c.uses_tp(age.tp);-- CGEN::globals_c CODE_FILE::uses_tp AM_GLOBAL_EXPR::tp
system_c.uses_tp(age.tp);-- CGEN::system_c CODE_FILE::uses_tp AM_GLOBAL_EXPR::tp
--globals_c.uses_global(age);
system_c.uses_global(age);-- CGEN::system_c CODE_FILE::uses_global
if is_const_expr(age.init) then-- CGEN::is_const_expr AM_GLOBAL_EXPR::init
code_c:=globals_c;-- CGEN::code_c CGEN::globals_c
globals_c+'\n';-- CGEN::globals_c CODE_FILE::plus
e:STR:=emit_expr(age.init);-- CGEN::emit_expr AM_GLOBAL_EXPR::init
if age.is_const then -- AM_GLOBAL_EXPR::is_const
globals_c+"const "; -- CGEN::globals_c CODE_FILE::plus
end;
globals_c+mang(age.tp)+' '+mang(age)+" = "+e+';';-- CGEN::globals_c CODE_FILE::plus CGEN::mang AM_GLOBAL_EXPR::tp CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
comment(globals_c,-- CGEN::globals_c
"Const ".append(mang(age.class_tp),"::",age.name.str));-- STR::append CGEN::mang AM_GLOBAL_EXPR::class_tp AM_GLOBAL_EXPR::name IDENT::str
else
if ~void(age.init) or -- AM_GLOBAL_EXPR::init BOOL::not
(age.tp.is_immutable and ~age.tp.is_builtin) then-- AM_GLOBAL_EXPR::tp AM_GLOBAL_EXPR::tp BOOL::not
-- will be initialized in main
code_c:=system_c;-- CGEN::code_c CGEN::system_c
globals_c+'\n'+mang(age.tp)+' '+mang(age)+';';-- CGEN::globals_c CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_GLOBAL_EXPR::tp CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus
comment(globals_c,"Shared "+mang(age.class_tp)-- CGEN::globals_c STR::plus CGEN::mang AM_GLOBAL_EXPR::class_tp
+"::"+age.name.str);-- STR::plus STR::plus AM_GLOBAL_EXPR::name IDENT::str
comment("Initialize shared "+mang(age.class_tp)-- CGEN::comment STR::plus CGEN::mang AM_GLOBAL_EXPR::class_tp
+"::"+age.name.str);-- STR::plus STR::plus AM_GLOBAL_EXPR::name IDENT::str
if ~void(age.init) then-- AM_GLOBAL_EXPR::init BOOL::not
in_constant := true;-- CGEN::in_constant
ndefer(mang(age)+" = "+emit_expr(age.init)+';');-- CGEN::ndefer CGEN::mang STR::plus STR::plus CGEN::emit_expr AM_GLOBAL_EXPR::init STR::plus
in_constant := false;-- CGEN::in_constant
else
ndefer(mang(age)+" = "+default_init(age.tp)+';');-- CGEN::ndefer CGEN::mang STR::plus STR::plus CGEN::default_init AM_GLOBAL_EXPR::tp STR::plus
end;
else
code_c:=globals_c;-- CGEN::code_c CGEN::globals_c
globals_c+'\n'+mang(age.tp)+' '+mang(age)-- CGEN::globals_c CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_GLOBAL_EXPR::tp CODE_FILE::plus CODE_FILE::plus CGEN::mang
+" = "+default_init(age.tp)+';';-- CODE_FILE::plus CODE_FILE::plus CGEN::default_init AM_GLOBAL_EXPR::tp CODE_FILE::plus
comment(globals_c,"Shared "+mang(age.class_tp)-- CGEN::globals_c STR::plus CGEN::mang AM_GLOBAL_EXPR::class_tp
+"::"+age.name.str);-- STR::plus STR::plus AM_GLOBAL_EXPR::name IDENT::str
end;
broadcast(age);-- CGEN::broadcast
end;
end;
end;
private generate_sys_tables is
-- make routines/tables needed by the SYS class
-- also, make const declarations for all the tags encountered
-- ultra short programs may not use INT_tag and CHAR_tag, but those
-- tags are used in builtin functions. so we make sure that all builtin
-- functions get their tags emitted
s::=tag_for(TP_BUILTIN::int);-- CGEN::tag_for TP_BUILTIN::int
s:=tag_for(TP_BUILTIN::char);-- CGEN::tag_for TP_BUILTIN::char
s:=tag_for(TP_BUILTIN::bool);-- CGEN::tag_for TP_BUILTIN::bool
s:=tag_for(TP_BUILTIN::flt);-- CGEN::tag_for TP_BUILTIN::flt
s:=tag_for(TP_BUILTIN::fltd);-- CGEN::tag_for TP_BUILTIN::fltd
s:=tag_for(TP_BUILTIN::str);-- CGEN::tag_for TP_BUILTIN::str
-- PRINT_OB may return a string that needs to be in an include file
-- included by System/Debug/print.c. One possibility is to add it to tags_h.
-- Thats not very clean, but easy.
if type_tables then tags_h+PRINT_OB::print(prog,self).str; end;-- CGEN::type_tables CGEN::tags_h CODE_FILE::plus PRINT_OB::print CGEN::prog FSTR::str
print_dec:FSTR;
code_c:=system_c;-- CGEN::code_c CGEN::system_c
system_c+"\nSTR gen_SYS_str_for_tp(INT i) {\n";-- CGEN::system_c CODE_FILE::plus
routine_code:=#FSTR+"\n";-- CGEN::routine_code FSTR::create FSTR::plus
ndefer(" switch (i) {");-- CGEN::ndefer
ts::=#ARRAY{STR}(tags.size);-- ARRAY{1}::create CGEN::tags FMAP{2}::size
loop
p::=tags.pairs!;-- CGEN::tags FMAP{2}::pairs!
if p.t1.is_immutable and ~void(p.t1.impl) and ~void(p.t1.impl.arr) then-- TUP{2}::t1 TUP{2}::t1 BOOL::not TUP{2}::t1 IMPL::arr BOOL::not
tags_h+"\n#define "+mang(p.t1)+"_ASIZE "+p.t1.impl.asize_val;-- CGEN::tags_h CODE_FILE::plus CODE_FILE::plus CGEN::mang TUP{2}::t1 CODE_FILE::plus CODE_FILE::plus TUP{2}::t1 IMPL::asize_val
end;
ts.set!("\n#define "+mang(p.t1)+"_tag "+p.t2);-- ARRAY{1}::set! STR::plus CGEN::mang TUP{2}::t1 STR::plus STR::plus TUP{2}::t2
end;
ts.sort; -- To keep stable over changes-- ARRAY{1}::sort
loop
tags_h+ts.elt!;-- CGEN::tags_h CODE_FILE::plus ARRAY{1}::elt!
end;
loop
p::=tags.pairs!;-- CGEN::tags FMAP{2}::pairs!
dummy::=#AM_STR_CONST;-- AM_STR_CONST::create
dummy.bval:=p.t1.str;-- AM_STR_CONST::bval TUP{2}::t1
ts.set!(" case "+mang(p.t1)+"_tag: return "-- ARRAY{1}::set! STR::plus CGEN::mang TUP{2}::t1
+emit_am_str_const(dummy)+";");-- STR::plus STR::plus CGEN::emit_am_str_const STR::plus
end;
ts.sort; -- To keep stable over changes-- ARRAY{1}::sort
loop
ndefer(ts.elt!);-- CGEN::ndefer ARRAY{1}::elt!
end;
ndefer(" default: fprintf(stderr,\"Internal error: unknown tag?\\n\");");-- CGEN::ndefer
if prog.psather then ndefer(" PSATHER_ABORT;\n"); end;-- CGEN::prog PROG::psather CGEN::ndefer
ndefer(" abort();\n");-- CGEN::ndefer
ndefer(" }");-- CGEN::ndefer
system_c+routine_code+"}\n\n";-- CGEN::system_c CGEN::routine_code CODE_FILE::plus
code_c:=system_c;-- CGEN::code_c CGEN::system_c
system_c+"\nBOOL gen_SYS_ob_eq(OB o1,OB o2) {\n";-- CGEN::system_c CODE_FILE::plus
system_c+" INT t1,t2;BOOL r=1;\n";-- CGEN::system_c CODE_FILE::plus
routine_code:=#FSTR+"\n";-- CGEN::routine_code FSTR::create FSTR::plus
ndefer(" if (o1==o2) return TRUE;");-- CGEN::ndefer
if prog.distributed then-- CGEN::prog PROG::distributed
ndefer(" if (FVOID(o1) || FVOID(o2)) return FALSE;");-- CGEN::ndefer
ndefer(" t1 = F_TAG(o1); t2 = F_TAG(o2);");-- CGEN::ndefer
else
ndefer(" if (o1==NULL || o2==NULL) return FALSE;");-- CGEN::ndefer
ndefer(" t1 = o1->header.tag; t2 = o2->header.tag;");-- CGEN::ndefer
end;
ndefer(" if (t1!=t2) return FALSE;");-- CGEN::ndefer
ndefer(" switch (t1) {");-- CGEN::ndefer
loop
tp::=tags.keys!;-- CGEN::tags FMAP{2}::keys!
tpstr::=mang(tp);-- CGEN::mang
system_c.uses_tp(tp);-- CGEN::system_c CODE_FILE::uses_tp
if tp.is_immutable then
if prog.distributed then-- CGEN::prog PROG::distributed
-- WARNING: the following code works only for atomic value types!
ndefer(" case "+tpstr+"_tag:");-- CGEN::ndefer STR::plus STR::plus
ndefer(" {"+tpstr+" v1,v2;F_VA_RATTR_NA(v1,"+tpstr+"_boxed,o1,immutable_part);");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
ndefer(" F_VA_RATTR_NA(v2,"+tpstr+"_boxed,o2,immutable_part);");-- CGEN::ndefer STR::plus STR::plus
ndefer(" return r&&"+value_compare(tp,"v1","v2")+";}");-- CGEN::ndefer STR::plus CGEN::value_compare STR::plus
else
ndefer(" case "+tpstr+"_tag:");-- CGEN::ndefer STR::plus STR::plus
ndefer(" {"+tpstr+" v1 = (("+tpstr+"_boxed)o1)->immutable_part;");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
ndefer(" "+tpstr+" v2 = (("+tpstr+"_boxed)o2)->immutable_part;");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
ndefer(" return r&&"+value_compare(tp,"v1","v2")+";}");-- CGEN::ndefer STR::plus CGEN::value_compare STR::plus
end;
end;
end;
ndefer(" default: return FALSE;");-- CGEN::ndefer
ndefer(" }");-- CGEN::ndefer
system_c+routine_code+"}\n\n";-- CGEN::system_c CGEN::routine_code CODE_FILE::plus
end;
private emit_prologue(f:AM_ROUT_DEF) pre ~void(f.sig) is-- AM_ROUT_DEF::sig BOOL::not
arg_list:ARRAY{STR}:=#(f.asize);-- ARRAY{1}::create AM_ROUT_DEF::asize
saw_outer_return:=false;-- CGEN::saw_outer_return
sig:SIG:=f.sig;-- AM_ROUT_DEF::sig
mangler.force_mangle(f[0].expr,"self",sig);-- CGEN::mangler MANGLE::force_mangle AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
newline; newline;-- CGEN::newline CGEN::newline
if f.sig.is_iter then code_c+"\n#undef IS_ITER\n#define IS_ITER 1\n";-- AM_ROUT_DEF::sig SIG::is_iter CGEN::code_c CODE_FILE::plus
else code_c+"\n#undef IS_ITER\n#define IS_ITER 0\n"; end;-- CGEN::code_c CODE_FILE::plus
comment(code_c,"Definition of "+sig.str);-- CGEN::code_c STR::plus SIG::str
code_c+'\n';-- CGEN::code_c CODE_FILE::plus
rout_index:STR;
if func_tables then-- CGEN::func_tables
rout_index:=PRINT_OB::register(f.sig);-- PRINT_OB::register AM_ROUT_DEF::sig
end;
if debug then-- CGEN::debug
code_c+"\n#line "-- CGEN::code_c
+f.source.line_num_in+" \""+f.source.file_in+"\"\n";-- CODE_FILE::plus CODE_FILE::plus AM_ROUT_DEF::source SFILE_ID::line_num_in CODE_FILE::plus CODE_FILE::plus AM_ROUT_DEF::source SFILE_ID::file_in CODE_FILE::plus
last_lineno:=f.source.line_num_in;-- CGEN::last_lineno AM_ROUT_DEF::source SFILE_ID::line_num_in
elsif pretty then-- CGEN::pretty
code_c+"\n/* #line "-- CGEN::code_c
+f.source.line_num_in+" \""+f.source.file_in+"\" */\n";-- CODE_FILE::plus CODE_FILE::plus AM_ROUT_DEF::source SFILE_ID::line_num_in CODE_FILE::plus CODE_FILE::plus AM_ROUT_DEF::source SFILE_ID::file_in CODE_FILE::plus
last_lineno:=f.source.line_num_in;-- CGEN::last_lineno AM_ROUT_DEF::source SFILE_ID::line_num_in
end;
if ~void(sig.ret) then code_c+mang(sig.ret)+' ';-- SIG::ret BOOL::not CGEN::code_c CODE_FILE::plus CGEN::mang SIG::ret CODE_FILE::plus
else code_c+"void ";-- CGEN::code_c CODE_FILE::plus
end;
-- The spec guarantees that external functions are mangled in
-- a special way: classname_funcname
if f.is_external then-- AM_ROUT_DEF::is_external
mangler.force_mangle(sig, sig.tp.str.append("_",sig.name.str),void);-- CGEN::mangler MANGLE::force_mangle SIG::tp STR::append SIG::name IDENT::str
end;
code_c+mang(sig)+'(';-- CGEN::code_c CODE_FILE::plus CGEN::mang CODE_FILE::plus
code_c.uses_sig(sig);-- CGEN::code_c CODE_FILE::uses_sig
iter_out_arg_locals:FLIST{AM_LOCAL_EXPR}; -- a list of temporaries for iter
-- out/inout args
out_args:BOOL:=false;
-- if an iter, pointer for frame, otherwise regular args
if f.is_iter then-- AM_ROUT_DEF::is_iter
-- just a single frame argument
code_c+mang(f.sig)+"_frame frame";-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_ROUT_DEF::sig CODE_FILE::plus
if func_tables then -- function frame-- CGEN::func_tables
code_c+", struct _func_frame *prev_func_frame";-- CGEN::code_c CODE_FILE::plus
end;
-- also, arguments are on frame
if f.size>1 then-- AM_ROUT_DEF::size INT::is_lt
loop
arg ::= f.elt!(1); -- AM_ROUT_DEF::elt!
lv:AM_LOCAL_EXPR := arg.expr;-- AM_FORMAL_ARG::expr
-- if out or inout args, a local will be used
-- instead of arg until the very end when results are
-- copied back
if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then -- AM_FORMAL_ARG::mode MODES::out_mode AM_FORMAL_ARG::mode MODES::inout_mode
iter_out_arg_locals := iter_out_arg_locals.push(lv);-- FLIST{1}::push
-- create a new argument expression
arg.expr := #AM_LOCAL_EXPR(lv.source, lv.name, -- AM_FORMAL_ARG::expr AM_LOCAL_EXPR::create AM_LOCAL_EXPR::source AM_LOCAL_EXPR::name
lv.tp, lv.as_type);-- AM_LOCAL_EXPR::tp AM_LOCAL_EXPR::as_type
out_args := true;
d::=mang(lv,sig); -- fix mangling before we delete the name-- CGEN::mang
lv.name:=void; -- otherwise -PO treats it as a standard local-- AM_LOCAL_EXPR::name
end;
mangler.force_mangle(arg.expr,"arg"+1.up!,sig);-- CGEN::mangler MANGLE::force_mangle AM_FORMAL_ARG::expr STR::plus INT::up!
end;
end;
else
-- if not an iter, declare arguments
if f.is_abstract then-- AM_ROUT_DEF::is_abstract
-- in abstract routine, arg names are canonical
code_c+mang(f.sig.tp)+" self";-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_ROUT_DEF::sig SIG::tp CODE_FILE::plus
if ~void(f.sig.args) then-- AM_ROUT_DEF::sig SIG::args BOOL::not
i::=0;
loop
e::=f.sig.args.elt!;-- AM_ROUT_DEF::sig SIG::args ARRAY{1}::elt!
arg_list[i] := " arg"+1.up!;-- ARRAY{1}::aset STR::plus INT::up!
code_c+", "+arg_type_str(e)+arg_list[i];-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CGEN::arg_type_str CODE_FILE::plus ARRAY{1}::aget
end;
end;
if func_tables then -- function frame-- CGEN::func_tables
code_c+", struct _func_frame *prev_func_frame";-- CGEN::code_c CODE_FILE::plus
end;
elsif f.is_external then -- AM_ROUT_DEF::is_external
loop i::=1.upto!(f.asize-1);-- INT::upto! AM_ROUT_DEF::asize INT::minus
e::=f[i];-- AM_ROUT_DEF::aget
assert ~void(e) and ~void(e.tp);-- BOOL::not AM_FORMAL_ARG::tp BOOL::not
if e.mode=MODES::inout_mode or e.mode=MODES::out_mode then-- AM_FORMAL_ARG::mode MODES::inout_mode AM_FORMAL_ARG::mode MODES::out_mode
lv:AM_LOCAL_EXPR := e.expr;-- AM_FORMAL_ARG::expr
arg_list[i]:=mang(lv.name.str, sig);-- ARRAY{1}::aset CGEN::mang AM_LOCAL_EXPR::name IDENT::str
out_args := true;
else
arg_list[i] := mang(e.expr,sig);-- ARRAY{1}::aset CGEN::mang AM_FORMAL_ARG::expr
end;
code_c+", ".separate!(arg_type_str(e)+' '+arg_list[i]);-- CGEN::code_c CODE_FILE::plus STR::separate! CGEN::arg_type_str STR::plus STR::plus ARRAY{1}::aget
end;
elsif sig.is_forked then -- SIG::is_forked
loop i::=0.upto!(f.asize-1);-- INT::upto! AM_ROUT_DEF::asize INT::minus
e::=f[i];-- AM_ROUT_DEF::aget
assert ~void(e) and ~void(e.tp);-- BOOL::not AM_FORMAL_ARG::tp BOOL::not
if i=0 then -- INT::is_eq
arg_list[i]:="self_to_be";-- ARRAY{1}::aset
code_c+"OB "+arg_list[i];-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus ARRAY{1}::aget
else
if e.mode=MODES::out_mode or e.mode=MODES::inout_mode-- AM_FORMAL_ARG::mode MODES::out_mode AM_FORMAL_ARG::mode MODES::inout_mode
then
lv:AM_LOCAL_EXPR := e.expr;-- AM_FORMAL_ARG::expr
arg_list[i]:=mang(lv.name.str, sig);-- ARRAY{1}::aset CGEN::mang AM_LOCAL_EXPR::name IDENT::str
out_args := true;
else
arg_list[i]:=mang(e.expr, sig);-- ARRAY{1}::aset CGEN::mang AM_FORMAL_ARG::expr
end;
code_c+", "+arg_type_str(e)+' '+arg_list[i];-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CGEN::arg_type_str CODE_FILE::plus CODE_FILE::plus ARRAY{1}::aget
end;
end;
else
loop i::=0.upto!(f.asize-1);-- INT::upto! AM_ROUT_DEF::asize INT::minus
e::=f[i];-- AM_ROUT_DEF::aget
assert ~void(e) and ~void(e.expr.tp);-- BOOL::not AM_FORMAL_ARG::expr AM_LOCAL_EXPR::tp BOOL::not
if e.mode=MODES::inout_mode or e.mode=MODES::out_mode then-- AM_FORMAL_ARG::mode MODES::inout_mode AM_FORMAL_ARG::mode MODES::out_mode
-- don't mangle arg yet! Instead, a temporary will be used
lv:AM_LOCAL_EXPR := e.expr;-- AM_FORMAL_ARG::expr
arg_list[i]:=mang(lv.name.str,sig);-- ARRAY{1}::aset CGEN::mang AM_LOCAL_EXPR::name IDENT::str
out_args := true;
else
arg_list[i] := mang(e.expr,sig);-- ARRAY{1}::aset CGEN::mang AM_FORMAL_ARG::expr
end;
code_c+", ".separate!(arg_type_str(e)+' '+arg_list[i]);-- CGEN::code_c CODE_FILE::plus STR::separate! CGEN::arg_type_str STR::plus STR::plus ARRAY{1}::aget
end;
if func_tables then -- function frame-- CGEN::func_tables
code_c+", struct _func_frame *prev_func_frame";-- CGEN::code_c CODE_FILE::plus
end;
end;
end;
code_c+") {";-- CGEN::code_c CODE_FILE::plus
in;-- CGEN::in
-- Declare/initialize out/inout stuff
if out_args and ~f.is_iter then-- AM_ROUT_DEF::is_iter BOOL::not
loop i::=1.upto!(f.asize-1);-- INT::upto! AM_ROUT_DEF::asize INT::minus
e::=f[i];-- AM_ROUT_DEF::aget
if e.mode = MODES::inout_mode or e.mode = MODES::out_mode then-- AM_FORMAL_ARG::mode MODES::inout_mode AM_FORMAL_ARG::mode MODES::out_mode
-- declare temporaries playing the role of *arg
init_str:STR;
if e.mode = MODES::inout_mode then-- AM_FORMAL_ARG::mode MODES::inout_mode
--declare & initialize the temporary
init_str := "*"+arg_list[i];-- STR::plus ARRAY{1}::aget
else
init_str := default_init(e.tp);-- CGEN::default_init AM_FORMAL_ARG::tp
end;
local::=dec_local_for_arg(e, f.sig, init_str);-- CGEN::dec_local_for_arg AM_ROUT_DEF::sig
end;
end;
end;
-- If PO is on, generate function frame
if func_tables then-- CGEN::func_tables
-- ndefer("void *_local_frame[]={");
-- because of a bug in GCC the above way to define local_frame compiles,
-- but produces buggy code. So we have to count the number of
-- elements first;
ll:STR:="";
cn::=0;
if f.is_iter then-- AM_ROUT_DEF::is_iter
loop
cn:=cn+1;-- INT::plus
e::=f.elt!;-- AM_ROUT_DEF::elt!
loc::=e.expr;-- AM_FORMAL_ARG::expr
if e.mode=MODES::out_mode or e.mode=MODES::inout_mode then -- AM_FORMAL_ARG::mode MODES::out_mode AM_FORMAL_ARG::mode MODES::inout_mode
loc:=iter_out_arg_locals.elt!;-- FLIST{1}::elt!
end;
ll:=ll+",".separate!("(void *)&frame->"+mang(loc,sig));-- STR::plus STR::separate! STR::plus CGEN::mang
end;
loop l::=f.locals.elt!;-- AM_ROUT_DEF::locals FLIST{1}::elt!
if ~void(l.name) and l/=f.rres then-- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::is_eq AM_ROUT_DEF::rres BOOL::not
l.needs_init:=true;-- AM_LOCAL_EXPR::needs_init
ll:=ll+",(void *)&frame->"+mang(l,sig);-- STR::plus STR::plus CGEN::mang
cn:=cn+1;-- INT::plus
end;
end;
else
loop
k::="(void *)&"+mang(f.elt!.expr,sig);-- STR::plus CGEN::mang AM_ROUT_DEF::elt! AM_FORMAL_ARG::expr
if f.is_external and 1.up!=1 then k:="NULL"; end;-- AM_ROUT_DEF::is_external INT::up! INT::is_eq
ll:=ll+",".separate!(k);-- STR::plus STR::separate!
cn:=cn+1;-- INT::plus
end;
loop l::=f.locals.elt!;-- AM_ROUT_DEF::locals FLIST{1}::elt!
if ~void(l.name) and l/=f.rres then-- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::is_eq AM_ROUT_DEF::rres BOOL::not
l.needs_init:=true;-- AM_LOCAL_EXPR::needs_init
ll:=ll+",(void *)&"+mang(l,sig);-- STR::plus STR::plus CGEN::mang
cn:=cn+1;-- INT::plus
end;
end;
end;
ndefer("void *_local_frame["+cn+"]={"+ll+"};");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
defer("struct _func_frame FF={"+rout_index);-- CGEN::defer STR::plus
if f.is_external or sig.is_forked then-- AM_ROUT_DEF::is_external SIG::is_forked
defer(",NULL");-- CGEN::defer
else
defer(",prev_func_frame");-- CGEN::defer
end;
defer(",_local_frame};");-- CGEN::defer
end;
-- We cannot do the following above before doing the -PO
-- stuff. We want the rest to be done before, so
-- that those locals are initialized BEFORE the function
-- frame. This is not critical for iters, as their frame
-- is initialized to zero anyway (because its allocated
-- on the heap).
if out_args and f.is_iter then-- AM_ROUT_DEF::is_iter
f.locals := f.locals.append(iter_out_arg_locals);-- AM_ROUT_DEF::locals AM_ROUT_DEF::locals FLIST{1}::append
-- don't need to declare: the layout structure will include
-- the temporary for args automatically
l: AM_LOCAL_EXPR;
loop e::=f.elt!;-- AM_ROUT_DEF::elt!
if e.mode=MODES::out_mode or e.mode=MODES::inout_mode then -- AM_FORMAL_ARG::mode MODES::out_mode AM_FORMAL_ARG::mode MODES::inout_mode
l := iter_out_arg_locals.elt!;-- FLIST{1}::elt!
case e.mode-- AM_FORMAL_ARG::mode
when MODES::inout_mode then-- MODES::inout_mode
ndefer("frame->"+mang(l, sig) + " = *(" + "frame->"+mang(e.expr, sig)+");");-- CGEN::ndefer STR::plus CGEN::mang STR::plus STR::plus STR::plus CGEN::mang AM_FORMAL_ARG::expr STR::plus
when MODES::out_mode then-- MODES::out_mode
-- default init
ndefer("frame->"+mang(l, sig) + " = " + default_init(l.tp)+';');-- CGEN::ndefer STR::plus CGEN::mang STR::plus STR::plus CGEN::default_init AM_LOCAL_EXPR::tp STR::plus
end;
end;
end;
end;
-- now emit local declarations (if an iter, they are on the
-- frame and don't need to be declared).
if ~f.is_iter and ~void(f.locals) then -- AM_ROUT_DEF::is_iter BOOL::not AM_ROUT_DEF::locals BOOL::not
loop
lv:AM_LOCAL_EXPR:=f.locals.elt!;-- AM_ROUT_DEF::locals FLIST{1}::elt!
assert ~void(lv) and ~void(lv.tp);-- BOOL::not AM_LOCAL_EXPR::tp BOOL::not
code_c.uses_tp(lv.tp); --here-- CGEN::code_c CODE_FILE::uses_tp AM_LOCAL_EXPR::tp
newline;-- CGEN::newline
if lv.is_volatile then code_c+"volatile "; end;-- AM_LOCAL_EXPR::is_volatile CGEN::code_c CODE_FILE::plus
if lv.needs_init or lv.tp.is_immutable then-- AM_LOCAL_EXPR::needs_init AM_LOCAL_EXPR::tp
def:STR:=default_init(lv.tp);-- CGEN::default_init AM_LOCAL_EXPR::tp
code_c+mang(lv.tp)+' '+mang(lv,sig)+" = "+def+';';-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_LOCAL_EXPR::tp CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
else
code_c+mang(lv.tp)+' '+mang(lv,sig)+';';-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_LOCAL_EXPR::tp CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus
end;
end;
end;
if sig.is_forked then -- unbox the self-- SIG::is_forked
newline;-- CGEN::newline
code_c+mang(f[0].expr.tp)+" self;";-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_LOCAL_EXPR::tp CODE_FILE::plus
ndefer( "self = " + cast(sig.tp,TP_BUILTIN::dollar_ob,"self_to_be",false)+';');-- CGEN::ndefer STR::plus CGEN::cast SIG::tp TP_BUILTIN::dollar_ob STR::plus
end;
-- if an iter, maybe return a dummy value when quit, so declare
-- one. Also generate switch statement. The first state
-- initializes any locals to the iter that need it. (It shouldn't
-- be possible to get there more than once in an invocation.)
if f.is_iter then-- AM_ROUT_DEF::is_iter
if ~void(sig.ret) then-- SIG::ret BOOL::not
newline;-- CGEN::newline
code_c+mang(sig.ret)+' '+"dummy = "+default_init(sig.ret)+';';-- CGEN::code_c CODE_FILE::plus CGEN::mang SIG::ret CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CGEN::default_init SIG::ret CODE_FILE::plus
end;
if prog.psather and (~prog.yields_in_locks or ~options.side_effects-- CGEN::prog PROG::psather CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or sig.get_se_context(prog).has_yield_in_lock) then-- BOOL::not SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
ndefer("if(frame->state) SET_EXCEPTION_STACK(frame->ex);");-- CGEN::ndefer
end;
ndefer("switch (frame->state) {");-- CGEN::ndefer
in;-- CGEN::in
loop
i::=0.upto!(f.num_yields);-- INT::upto! AM_ROUT_DEF::num_yields
ndefer("case "+i+": goto state"+i+';');-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
end;
ndefer("}");-- CGEN::ndefer
move_out;-- CGEN::move_out
ndefer("state0:;");-- CGEN::ndefer
state_counter:=1;-- CGEN::state_counter
-- initialize any locals that need it
if ~void(f.locals) then-- AM_ROUT_DEF::locals BOOL::not
loop i::=f.locals.elt!;-- AM_ROUT_DEF::locals FLIST{1}::elt!
if i.needs_init then-- AM_LOCAL_EXPR::needs_init
ndefer("frame->"+mang(i,sig)-- CGEN::ndefer STR::plus CGEN::mang
+" = "+default_init(i.tp)+";");-- STR::plus STR::plus CGEN::default_init AM_LOCAL_EXPR::tp STR::plus
end;
end;
end;
end;
current_arg_list := arg_list;-- CGEN::current_arg_list
current_iter_out_arg_locals := iter_out_arg_locals;-- CGEN::current_iter_out_arg_locals
end;
arg_type_str(e:AM_FORMAL_ARG): STR is
res::= mang(e.expr.tp);-- CGEN::mang AM_FORMAL_ARG::expr AM_LOCAL_EXPR::tp
if e.mode=MODES::inout_mode or e.mode=MODES::out_mode or-- AM_FORMAL_ARG::mode MODES::inout_mode AM_FORMAL_ARG::mode MODES::out_mode
e.tp.kind = TP_KIND::ext_fortran_tp-- AM_FORMAL_ARG::tp INT::is_eq TP_KIND::ext_fortran_tp
then
res := res+"*";-- STR::plus
end;
return res;
end;
arg_type_str(e:ARG): STR is
res::= mang(e.tp);-- CGEN::mang ARG::tp
if e.mode=MODES::inout_mode or e.mode=MODES::out_mode or -- ARG::mode MODES::inout_mode ARG::mode MODES::out_mode
e.tp.kind = TP_KIND::ext_fortran_tp-- ARG::tp INT::is_eq TP_KIND::ext_fortran_tp
then
res := res+"*";-- STR::plus
end;
return res;
end;
private emit_epilogue(f:AM_ROUT_DEF) is
if ~void(current_am_rout_def.specul_prefetch) then-- CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch BOOL::not
ndefer("PREFETCH_WAIT("+emit_expr(current_am_rout_def.specul_prefetch)+");");-- CGEN::ndefer STR::plus CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch STR::plus
end;
if ~saw_outer_return then-- CGEN::saw_outer_return BOOL::not
callee_copy_out;-- CGEN::callee_copy_out
end;
if chk_return and ~saw_outer_return-- CGEN::chk_return CGEN::saw_outer_return
and ~f.is_iter and-- BOOL::not AM_ROUT_DEF::is_iter BOOL::not
~void(f.sig.ret) then-- AM_ROUT_DEF::sig SIG::ret BOOL::not
-- if it has a return value, it is necessary to
-- make sure doesn't exit without a return
runtime_error("Last statement wasn't return");-- CGEN::runtime_error
end;
code_c+routine_code; -- output all the code-- CGEN::code_c CGEN::routine_code
if f.is_iter then -- add an explicit 'quit'-- AM_ROUT_DEF::is_iter
newline; code_c+"frame->state = -1;"; -- CGEN::newline CGEN::code_c CODE_FILE::plus
if ~void(f.sig.ret) then newline; code_c+"return dummy;";-- AM_ROUT_DEF::sig SIG::ret BOOL::not CGEN::newline CGEN::code_c CODE_FILE::plus
else newline; code_c+"return;";-- CGEN::newline CGEN::code_c CODE_FILE::plus
end;
end;
move_out; newline; code_c+"}";-- CGEN::move_out CGEN::newline CGEN::code_c CODE_FILE::plus
if func_tables then-- CGEN::func_tables
PRINT_OB::print_frame(prog,self,code_c,f,current_iter_out_arg_locals); -- PRINT_OB::print_frame CGEN::prog CGEN::code_c CGEN::current_iter_out_arg_locals
end;
-- esc: we don't want to split here, because there still are
-- references to the code file later on (see emit_routine)
--code_c.good_place_to_split;
end;
private generate_bnd_rout_stubs is
-- Generate declarations for bound routine objects and
-- make stub functions to execute them
code_c:=system_c;-- CGEN::code_c CGEN::system_c
loop
until!(void(bnd_rout_creates) or bnd_rout_creates.is_empty);-- CGEN::bnd_rout_creates CGEN::bnd_rout_creates FLIST{1}::is_empty
-- this is needed to avoid generating the same
-- stubs multiple times
e::=bnd_rout_creates.pop; -- CGEN::bnd_rout_creates FLIST{1}::pop
code_c.uses_bnd_rout_create(e); -- announce for creation of a stub-- CGEN::code_c CODE_FILE::uses_bnd_rout_create
code_c.uses_layout(#BOUND_OBJECT_LAYOUT(e)); -- announce use of layout-- CGEN::code_c CODE_FILE::uses_layout BOUND_OBJECT_LAYOUT::create
name::=mang(e); -- get its name-- CGEN::mang
forbid(name+"_ob");-- CGEN::forbid STR::plus
forbid(name+"_ob_struct");-- CGEN::forbid STR::plus
-- change in biter too
if ~void(e.fun.ret) and ~e.is_remote then code_c+mang(e.fun.ret)+' ';-- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not AM_BND_CREATE_EXPR::is_remote BOOL::not CGEN::code_c CODE_FILE::plus CGEN::mang AM_BND_CREATE_EXPR::fun SIG::ret CODE_FILE::plus
else code_c+"void ";-- CGEN::code_c CODE_FILE::plus
end;
code_c+name+'('+name+"_ob ob"; -- name(name_ob ob-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
-- note that out and inout arguments must be left
-- unbound. The check is done earlier.
loop -- generate variable for unb args
-- Well, we may have out and inout bound args if compiling
-- psather. They are used for remote execution
i::=e.unbnd_args.elt!;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::elt!
num::=0.up!;-- INT::up!
dec:STR;
if i=0 then-- INT::is_eq
if ~e.fun.tp.is_external then -- AM_BND_CREATE_EXPR::fun SIG::tp BOOL::not
dec:=mang(e.fun.tp);-- CGEN::mang AM_BND_CREATE_EXPR::fun SIG::tp
code_c+", "+dec+" unbound_arg"+num;-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
else
a::=e.fun.args[i-1];-- AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::aget INT::minus
code_c+", "+arg_type_str(a)+" unbound_arg"+num;-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CGEN::arg_type_str CODE_FILE::plus CODE_FILE::plus
end;
end;
if func_tables then-- CGEN::func_tables
code_c+",struct _func_frame *pFF";-- CGEN::code_c CODE_FILE::plus
end;
code_c+") {"+eol;-- CGEN::code_c CODE_FILE::plus CGEN::eol
code_c.uses_sig(e.fun);-- CGEN::code_c CODE_FILE::uses_sig AM_BND_CREATE_EXPR::fun
arg_list::=#ARRAY{STR}(e.fun.args.size+1);-- ARRAY{1}::create AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::size INT::plus
-- Make a dummy routine call and generate it
-- Note that we are not daeling here with parameter passing
-- stuff. It should be handled by the called ``real'' function
-- and also at the point of the call as for normal routines
bnd::=0; -- The index of the next bound argument
unbnd::=0; -- The index of the next unbound argument
is_bnd:BOOL; -- So, is the next arg bound or unbound?
loop
i::=arg_list.ind!; -- The index we're on.-- ARRAY{1}::ind!
if bnd<e.bnd_args.size then-- INT::is_lt AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::size
if e.bnd_args[bnd]=i then is_bnd:=true;-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::aget INT::is_eq
elsif e.unbnd_args[unbnd]=i then is_bnd:=false;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::aget INT::is_eq
else barf("Ran off unbound arg list");-- CGEN::barf
end;
elsif e.unbnd_args[unbnd]=i then is_bnd:=false;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::aget INT::is_eq
else barf("Ran off unbound arg list 2nd");-- CGEN::barf
end;
isout::=false;
if i>0 and e.fun.args.elt!.mode/=MODES::in_mode then-- INT::is_lt AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::elt! ARG::mode MODES::in_mode BOOL::not
isout:=true;
end;
if ~(i=0 and e.fun.tp.is_external) then-- INT::is_eq AM_BND_CREATE_EXPR::fun SIG::tp BOOL::not
if is_bnd then
if isout then
arg_list[i]:="&ob->bound_arg"+bnd;-- ARRAY{1}::aset STR::plus
else
arg_list[i]:="ob->bound_arg"+bnd;-- ARRAY{1}::aset STR::plus
end;
else
arg_list[i]:="unbound_arg"+unbnd;-- ARRAY{1}::aset STR::plus
end;
end;
if is_bnd then
bnd:=bnd+1;-- INT::plus
else
unbnd:=unbnd+1;-- INT::plus
end;
end;
routine_code:=#FSTR;-- CGEN::routine_code FSTR::create
make_sure_emitted(e.fun);-- CGEN::make_sure_emitted AM_BND_CREATE_EXPR::fun
func_res:STR:=void;
in_bnd_rout_call:=true;-- CGEN::in_bnd_rout_call
ec::=emit_call(e.fun,arg_list);-- CGEN::emit_call AM_BND_CREATE_EXPR::fun
in_bnd_rout_call:=false;-- CGEN::in_bnd_rout_call
code_c+routine_code;-- CGEN::code_c CGEN::routine_code
if ~void(e.fun.ret) then -- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not
if e.is_remote then -- AM_BND_CREATE_EXPR::is_remote
code_c+" ob->ret_arg=";-- CGEN::code_c CODE_FILE::plus
else
code_c+" return ";-- CGEN::code_c CODE_FILE::plus
end;
else code_c+" ";-- CGEN::code_c CODE_FILE::plus
end;
code_c+ec+";\n}\n\n";-- CGEN::code_c CODE_FILE::plus CODE_FILE::plus
end;
end;
private generate_bnd_iter_stubs is
-- generates wrapper function for iter call
l_ret_val : STR;
loop
until!(void(bnd_iter_creates) or bnd_iter_creates.is_empty);-- CGEN::bnd_iter_creates CGEN::bnd_iter_creates FLIST{1}::is_empty
-- this is needed to avoid generating the same
-- stubs multiple times
e::=bnd_iter_creates.pop; -- CGEN::bnd_iter_creates FLIST{1}::pop
-- tell it to generate a stub
code_c.uses_bnd_iter_create(e);-- CGEN::code_c CODE_FILE::uses_bnd_iter_create
-- tell it to generate a frame plus the iter frame referenced inside
-- this does not create a dependency, it just tells it to emit in
-- the same file a FRAME for the iterator
if e.fun.tp.is_abstract then-- AM_BND_CREATE_EXPR::fun SIG::tp
code_c.uses_layout(#ABSTRACT_FRAME_LAYOUT(e.fun,prog)); -- CGEN::code_c CODE_FILE::uses_layout ABSTRACT_FRAME_LAYOUT::create AM_BND_CREATE_EXPR::fun CGEN::prog
else
-- the following table is filled in emit and in emit_am_bnd_iter
iframe:AM_ROUT_DEF:= itersig_map.get(e.fun);-- CGEN::itersig_map FMAP{2}::get AM_BND_CREATE_EXPR::fun
if void(iframe) then
barf("Iter signature not found in : generate_bnd_iter"); -- CGEN::barf
end;
code_c.uses_layout(#FRAME_LAYOUT(iframe,prog)); -- CGEN::code_c CODE_FILE::uses_layout FRAME_LAYOUT::create CGEN::prog
end;
code_c.uses_layout(#BOUND_ITER_FRAME_LAYOUT(e,prog)); -- CGEN::code_c CODE_FILE::uses_layout BOUND_ITER_FRAME_LAYOUT::create CGEN::prog
name::=mang(e);-- CGEN::mang
forbid(name+"_iter_ob");-- CGEN::forbid STR::plus
forbid(name+"_iter_ob_struct");-- CGEN::forbid STR::plus
-- generate fct.head eg.INT call_function_name (name_iter_ob f)
if ~void(e.fun.ret) then -- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not
code_c+mang(e.fun.ret)+' ';-- CGEN::code_c CODE_FILE::plus CGEN::mang AM_BND_CREATE_EXPR::fun SIG::ret CODE_FILE::plus
else
code_c+"void "; -- CGEN::code_c CODE_FILE::plus
end;
code_c+name+"_call_function" + '(' + name + "_iter_ob f"; -- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if func_tables then-- CGEN::func_tables
code_c+", struct _func_frame *pFF";-- CGEN::code_c CODE_FILE::plus
end;
code_c+")";-- CGEN::code_c CODE_FILE::plus
code_c+"{"+eol;-- CGEN::code_c CODE_FILE::plus CGEN::eol
code_c.uses_sig(e.fun); -- CGEN::code_c CODE_FILE::uses_sig AM_BND_CREATE_EXPR::fun
if ~void(e.fun.ret) then -- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not
code_c+" "+mang(e.fun.ret)+' '+" ret_val;\n"; -- CGEN::code_c CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_BND_CREATE_EXPR::fun SIG::ret CODE_FILE::plus CODE_FILE::plus
end;
-- the switch stm
routine_code := #FSTR;-- CGEN::routine_code FSTR::create
--in;
ndefer("switch (f->state) { \n case 0: goto state0; \n");-- CGEN::ndefer
defer(" case 1: goto state1;\n}");-- CGEN::defer
-- state0:;
ndefer("state0:;");-- CGEN::ndefer
comment("Allocate iter frame, set state and once args.");-- CGEN::comment
comment("Allocate space for real iter frame.");-- CGEN::comment
-- if iter id abstract then
-- if self is unbound, i.e. _:$ELT.elt! then
-- self must be in oncearg0
-- else if e.g. b :$ELT then and b.elt! then
-- self, 'b' can be found in bound_arg0
-- this second test not yet incorporated
if e.fun.tp.is_abstract then -- AM_BND_CREATE_EXPR::fun SIG::tp
dtbl_ptr ::= mang(e.fun);-- CGEN::mang AM_BND_CREATE_EXPR::fun
self_ptr : STR;
-- lazy evaluation !!
if ((e.bnd_args.size>0) and (e.bnd_args[0] = 0)) then-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::size INT::is_lt AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::aget INT::is_eq
self_ptr := "bound_arg0";
else
self_ptr := "oncearg0";
end;
if chk_void and ~null_segfaults then-- CGEN::chk_void CGEN::null_segfaults BOOL::not
ndefer("if (f->"+self_ptr+" == NULL) {"); in;-- CGEN::ndefer STR::plus STR::plus CGEN::in
runtime_error("Dispatched call to "+e.fun.str + " on void self in " + current_function_str); move_out; -- CGEN::runtime_error STR::plus AM_BND_CREATE_EXPR::fun SIG::str STR::plus CGEN::current_function_str CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
ndefer("f->iter_frame = ("
+ mang(e.fun)+"_frame)"-- CGEN::ndefer STR::plus CGEN::mang AM_BND_CREATE_EXPR::fun
+"(*"+ dtbl_ptr-- STR::plus STR::plus STR::plus
+"[TAG(f->"+self_ptr+")].alloc_frame)();");-- STR::plus STR::plus STR::plus
else
ndefer("f->iter_frame = OB_ALLOC(");-- CGEN::ndefer
defer(mang(e.fun)+"_frame);");-- CGEN::defer CGEN::mang AM_BND_CREATE_EXPR::fun STR::plus
end;
comment("Initialize iter state.");-- CGEN::comment
ndefer("f->iter_frame->state=0;");-- CGEN::ndefer
-- fill in arguments : first once (state0) then hots (state1)
-- first treat once arguments
comment("Fill in once arguments.");-- CGEN::comment
loop a ::= e.unbnd_args.elt!; i ::= 0.up!; -- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::elt! INT::up!
if a = 0 then -- INT::is_eq
ndefer("f->iter_frame->self = f->oncearg0;"); -- CGEN::ndefer
else
if void(e.fun.hot) then -- AM_BND_CREATE_EXPR::fun SIG::hot
ndefer("f->iter_frame->arg"+a+" = f->oncearg"+i+";"); -- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
else
hot ::= e.fun.hot[a-1];-- AM_BND_CREATE_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
if ~hot then ndefer("f->iter_frame->arg"+a+" = f->oncearg"+i+";"); end;-- BOOL::not CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
end;
end;
end;
-- now go over bnd args
loop a ::= e.bnd_args.elt!; i ::= 0.up!;-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::elt! INT::up!
if a = 0 then -- INT::is_eq
ndefer("f->iter_frame->self = f->bound_arg0;"); -- CGEN::ndefer
else
if void(e.fun.hot) then -- AM_BND_CREATE_EXPR::fun SIG::hot
ndefer("f->iter_frame->arg"+a+" = f->bound_arg"+i+";"); -- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
else
hot ::= e.fun.hot[a-1]; -- access of void error-- AM_BND_CREATE_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
if ~hot then ndefer("f->iter_frame->arg"+a+" = f->");-- BOOL::not CGEN::ndefer STR::plus STR::plus
defer("bound_arg"+i+";"); -- CGEN::defer STR::plus STR::plus
end;
end;
end;
end; -- ends loop
-- state1:; i.e. treatment of hot args
ndefer("state1:; \n ");-- CGEN::ndefer
comment("Set hot arguments, call iter and check iter state.");-- CGEN::comment
-- argument 0 is never hot (self is by def. always once )
comment("Fill in hot arguments."); -- CGEN::comment
-- if there are no hots don`t do nothing !
if ~void(e.fun.hot) then -- AM_BND_CREATE_EXPR::fun SIG::hot BOOL::not
-- check out unbnd first
loop a ::= e.unbnd_args.elt!; i ::= 0.up!;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::elt! INT::up!
if a /= 0 then -- INT::is_eq BOOL::not
hot ::= e.fun.hot[a-1];-- AM_BND_CREATE_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
if hot then ndefer("f->iter_frame->arg"+a+" = f->");-- CGEN::ndefer STR::plus STR::plus
defer("hotarg"+i+";"); end; -- CGEN::defer STR::plus STR::plus
end;
end;
-- check out bnd args
loop a ::= e.bnd_args.elt!; i ::= 0.up!; -- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::elt! INT::up!
if a /= 0 then -- INT::is_eq BOOL::not
hot ::= e.fun.hot[a-1];-- AM_BND_CREATE_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
if hot then ndefer("f->iter_frame->arg"+a+" = f->");-- CGEN::ndefer STR::plus STR::plus
defer("bound_arg"+i+";"); end;-- CGEN::defer STR::plus STR::plus
end;
end;
end;
-- The call to the bound iter stub looks always something like that:
-- void bound2_call_function(bound2_iter_ob f){
-- ... MAIN_foob_INT_INT_INT_IN(f->iter_frame)
-- NOTE. self is part of the frame
-- void bound(bound_ob ob, unbnds ...){
-- ... MAIN_foo_INT_INT_INT_INT(
-- ob->bound_arg0, unbound_arg0, unbound_arg1, ob->bound_arg1,
-- ob->bound_arg2);
-- NOTE, unlike in the case of bound routines, here the entire context has to
-- be passed at each invokation rendering the above form more apt.
-- The stub is the incarnation of an iterator.
comment("call iter");-- CGEN::comment
-- one arg. for self, since emit_call expects self in arg_list[0]
-- which we do not use
arg_list::=#ARRAY{STR}(1); -- ARRAY{1}::create
arg_list[0] := "f->iter_frame"; -- always of this form (see comment above)-- ARRAY{1}::aset
iter_call ::= emit_call(e.fun, arg_list)+";";-- CGEN::emit_call AM_BND_CREATE_EXPR::fun STR::plus
-- all of the below special cases should be handled by emit_call
-- and more so
-- iter call should be handled similar to dispatched call
-- since the iter frame has bow been allocated and filled up
-- we obtain 'self' for the abstract iter from the real iter
-- frame i.e. no need to check whether self is bnd or unhnd!
--iter_call : STR;
--if e.fun.tp.is_abstract then
--dtbl_ptr ::= mang(e.fun);
--iter_call :=
--"(*"+dtbl_ptr+"[TAG(f->iter_frame->self)].iter)(f->iter_frame";
--else
-- iter_call := mang(e.fun) + "(f->iter_frame";
--end;
--if func_tables then
-- iter_call := iter_call + ", pFF);"
--else
-- iter_call := iter_call + ");"
--end;
if ~void(e.fun.ret) then -- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not
ndefer("ret_val = " + iter_call);-- CGEN::ndefer STR::plus
ndefer("f->state = (f->iter_frame->state == -1 ? -1 : 1);");-- CGEN::ndefer
ndefer("return ret_val" + ";\n}");-- CGEN::ndefer STR::plus
--ndefer("/* last */");
else
-- iter is not returning anything
ndefer(iter_call);-- CGEN::ndefer
ndefer("f->state = (f->iter_frame->state == -1 ? -1 : 1);");-- CGEN::ndefer
ndefer("return;\n}");-- CGEN::ndefer
--ndefer("/* last */");
end;
code_c + routine_code;-- CGEN::code_c CGEN::routine_code
make_sure_emitted(e.fun); -- CGEN::make_sure_emitted AM_BND_CREATE_EXPR::fun
end;
end;
private generate_dispatch_rout_and_iters is
-- make sure that all functions reachable through
-- dispatch tables are actually emited
-- Note that we do not emit any features in partial classes
-- since partial classes cannot be instantiated
loop
loop
abs_rout::=abstract_routs.elt!;-- CGEN::abstract_routs FLIST{1}::elt!
gh:FSET{$TP};
fst::=abs_rout.sig.tp;-- AM_ROUT_DEF::sig SIG::tp
--#OUT+"Working on Dispatch Table for "+abs_rout.sig.str+", tp: "+fst.str+"\n";
typecase fst
when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); -- CGEN::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::des_of
end;
loop
e::=gh.elt!;-- FSET{1}::elt!
-- skip partial classes - they can never be instantiated
if ~e.is_partial then-- BOOL::not
if tags.get(e)/=0 then-- CGEN::tags FMAP{2}::get INT::is_eq BOOL::not
real_sig:SIG:=e.ifc.sig_conforming_to(abs_rout.sig);-- IFC::sig_conforming_to AM_ROUT_DEF::sig
if ~void(real_sig) then -- BOOL::not
make_sure_emitted(real_sig);-- CGEN::make_sure_emitted
end;
end;
end;
end;
end;
loop
abs_iter::=abstract_iters.elt!;-- CGEN::abstract_iters FLIST{1}::elt!
gh:FSET{$TP};
fst::=abs_iter.sig.tp;-- AM_ROUT_DEF::sig SIG::tp
--#OUT+"Working on Dispatch Table for "+abs_iter.sig.str+", tp: "+fst.str+"\n";
typecase fst
when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); -- CGEN::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::des_of
end;
loop
e::=gh.elt!;-- FSET{1}::elt!
-- skip partial classes - they can never be instantiated
if ~e.is_partial then-- BOOL::not
if tags.get(e)/=0 then-- CGEN::tags FMAP{2}::get INT::is_eq BOOL::not
real_sig:SIG:=e.ifc.sig_conforming_to(abs_iter.sig);-- IFC::sig_conforming_to AM_ROUT_DEF::sig
if ~void(real_sig) then -- BOOL::not
make_sure_emitted(real_sig);-- CGEN::make_sure_emitted
end;
end;
end;
end;
end;
-- we could have generated some more functions,
-- which in turn could have changed the reachable
-- code, so we have to adjust the tag table, and
-- if there are any changes there, we need to recheck
-- dispatched calls.
while!(adjust_tag_table);-- CGEN::adjust_tag_table
end;
end;
private generate_dispatch_tables is
-- first, emit dispatch tables for functions
loop
abs_rout ::= abstract_routs.elt!;-- CGEN::abstract_routs FLIST{1}::elt!
emit_dispatch_func_table(abs_rout); -- CGEN::emit_dispatch_func_table
end;
-- emit dispatch table for iters
loop
abs_iter ::= abstract_iters.elt!;-- CGEN::abstract_iters FLIST{1}::elt!
emit_dispatch_iter_table(abs_iter); -- CGEN::emit_dispatch_iter_table
end;
end;
private attr emitted_dispatch_wrappers:FMAP{SIG,STR};
private emit_dispatched_version(s,abs:SIG):STR is
-- emit a wrapper function for boxing/unboxing value types
-- when dispatched. Return the function name generated.
-- If no boxing has to happen, don't generate anything.
-- 's' is the signature to call, and 'abs' is the signature
-- of the dispatch.
call, decl:STR;
-- First, see if we can weasel out and not worry about boxing.
if ~s.is_builtin then -- we have to generate a function-- SIG::is_builtin BOOL::not
-- for all builtins
w::= abs.tp=s.tp and abs.ret=s.ret;-- SIG::tp SIG::tp SIG::ret SIG::ret
loop
while!(w);
if s.args.elt!/=abs.args.elt! then w:=false; end;-- SIG::args ARRAY{1}::elt! ARG::is_eq SIG::args ARRAY{1}::elt! BOOL::not
end;
if w then
return mang(s);-- CGEN::mang
end;
end;
-- It is possible to emit a wrapper more than once if there
-- are multiple abstract types it could be dispatched from.
-- So we keep them in a table to avoid duplication.
res::=emitted_dispatch_wrappers.get(s);-- CGEN::emitted_dispatch_wrappers FMAP{2}::get
if ~void(res) then return res; end;-- BOOL::not
code_c:=unbox_c;-- CGEN::code_c CGEN::unbox_c
unbox_c.uses_unbox(s,abs);-- CGEN::unbox_c CODE_FILE::uses_unbox
unbox_c.uses_sig(abs);-- CGEN::unbox_c CODE_FILE::uses_sig
if ~s.is_builtin or s.is_iter then-- builtins have no body-- SIG::is_builtin BOOL::not SIG::is_iter
dispatch_c.uses_sig(s);-- CGEN::dispatch_c CODE_FILE::uses_sig
unbox_c.uses_sig(s);-- CGEN::unbox_c CODE_FILE::uses_sig
end;
dispatch_c.uses_unbox(s,abs);-- CGEN::dispatch_c CODE_FILE::uses_unbox
-- until mangling is really correct, use func_unbox as name
res:=mang(s)+"_unbox";-- CGEN::mang STR::plus
unbox_c+'\n';-- CGEN::unbox_c CODE_FILE::plus
comment(unbox_c,"Wrapper to unbox "+s.str);-- CGEN::unbox_c STR::plus SIG::str
unbox_c+'\n';-- CGEN::unbox_c CODE_FILE::plus
if void(s.ret) then-- SIG::ret
unbox_c+"void ";-- CGEN::unbox_c CODE_FILE::plus
else
unbox_c+mang(abs.ret)+' '; -- CGEN::unbox_c CODE_FILE::plus CGEN::mang SIG::ret CODE_FILE::plus
end;
pog::="";
if func_tables then-- CGEN::func_tables
pog:=",struct _func_frame *pFF";
end;
if s.is_iter then-- SIG::is_iter
unbox_c+res+'('+mang(abs)+"_frame frame"+pog+") {\n"-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus
else-- CODE_FILE::plus
if abs.tp.is_abstract and-- SIG::tp
(s.tp.is_immutable or s.tp=TP_BUILTIN::ext_ob) then-- SIG::tp SIG::tp TP_BUILTIN::ext_ob
unbox_c+res+"("+mang(s.tp)+"_boxed self";-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CGEN::mang SIG::tp CODE_FILE::plus
else
unbox_c+res+"("+mang(s.tp)+" self";-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CGEN::mang SIG::tp CODE_FILE::plus
end;
loop
a::=s.args.elt!;-- SIG::args ARRAY{1}::elt!
set::=a.tp;-- ARG::tp
abset::=abs.args.elt!.tp;-- SIG::args ARRAY{1}::elt! ARG::tp
idx::=1.up!;-- INT::up!
if abset.is_abstract and
(set.is_immutable or set=TP_BUILTIN::ext_ob) then-- TP_BUILTIN::ext_ob
unbox_c+", "+mang(set)+"_boxed arg"+idx;-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus
else
unbox_c+", "+arg_type_str(a) + " arg"+idx;-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus CGEN::arg_type_str CODE_FILE::plus CODE_FILE::plus
end;
end;
unbox_c+pog+") {\n";-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus
end;
routine_code:=#FSTR;-- CGEN::routine_code FSTR::create
if s.is_iter then-- SIG::is_iter
call:=mang(s)+"(("+mang(s)+"_frame) frame";-- CGEN::mang STR::plus STR::plus CGEN::mang STR::plus
decl:=mang(s)+'('+mang(s)+"_frame";-- CGEN::mang STR::plus STR::plus CGEN::mang STR::plus
if func_tables then-- CGEN::func_tables
call:=call+",pFF";-- STR::plus
decl:=decl+",struct _func_frame *";-- STR::plus
end;
call:=call+')';-- STR::plus
decl:=decl+')';-- STR::plus
if ~void(s.ret) then-- SIG::ret BOOL::not
call:="return "+cast(abs.ret,s.ret,call,false);-- STR::plus CGEN::cast SIG::ret SIG::ret
decl:=mang(s.ret)+' '+decl;-- CGEN::mang SIG::ret STR::plus STR::plus
else
decl:="void "+decl;-- STR::plus
end;
else
if s.is_builtin then-- SIG::is_builtin
arg_list ::= #ARRAY{STR}(s.num_args+1);-- ARRAY{1}::create SIG::num_args INT::plus
arg_list[0] := cast(s.tp, abs.tp, "self",false);-- ARRAY{1}::aset CGEN::cast SIG::tp SIG::tp
loop i::=1.upto!(s.num_args);-- INT::upto! SIG::num_args
arg_list[i] := cast(s.args[i-1].tp, abs.args[i-1].tp,"arg"+i,true);-- ARRAY{1}::aset CGEN::cast SIG::args ARRAY{1}::aget INT::minus ARG::tp SIG::args ARRAY{1}::aget INT::minus ARG::tp STR::plus
end;
call := process_builtin_routs(s, arg_list);-- CGEN::process_builtin_routs
else
call:=mang(s)+'('+cast(s.tp,abs.tp,"self",false);-- CGEN::mang STR::plus STR::plus CGEN::cast SIG::tp SIG::tp
decl:=mang(s)+'('+mang(s.tp);-- CGEN::mang STR::plus STR::plus CGEN::mang SIG::tp
loop i::=1.upto!(s.num_args);-- INT::upto! SIG::num_args
call:=call+", "+cast(s.args[i-1].tp,abs.args[i-1].tp,"arg"+i,false);-- STR::plus STR::plus CGEN::cast SIG::args ARRAY{1}::aget INT::minus ARG::tp SIG::args ARRAY{1}::aget INT::minus ARG::tp STR::plus
decl:=decl+", "+mang(s.args[i-1].tp);-- STR::plus STR::plus CGEN::mang SIG::args ARRAY{1}::aget INT::minus ARG::tp
end;
if func_tables then-- CGEN::func_tables
call:=call+",pFF";-- STR::plus
decl:=decl+",struct _func_frame *";-- STR::plus
end;
call:=call+')';-- STR::plus
decl:=decl+')';-- STR::plus
end;
if ~void(s.ret) then-- SIG::ret BOOL::not
call:="return "+cast(abs.ret,s.ret,call,false);-- STR::plus CGEN::cast SIG::ret SIG::ret
decl:=mang(s.ret)+' '+decl;-- CGEN::mang SIG::ret STR::plus STR::plus
else
decl:="void "+decl;-- STR::plus
if void(call) then call:=""; end;
end;
end;
if s.is_builtin then-- SIG::is_builtin
unbox_c+' '+routine_code+"\n "+call+";\n"+"}\n";-- CGEN::unbox_c CODE_FILE::plus CGEN::routine_code CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
else
-- unbox_c+' '+decl+";\n "+routine_code+"\n "+call+";\n"+"}\n";
unbox_c+' '+routine_code+"\n "+call+";\n"+"}\n";-- CGEN::unbox_c CODE_FILE::plus CGEN::routine_code CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
emitted_dispatch_wrappers:=emitted_dispatch_wrappers.insert(s,res);-- CGEN::emitted_dispatch_wrappers CGEN::emitted_dispatch_wrappers FMAP{2}::insert
return res;
end;
private emit_dispatched_allocator(s, abs:SIG):STR is
res ::= mang(s)+"_frame_alloc";-- CGEN::mang STR::plus
--emit dispatched allocator only once!
if ~emitted_iter_allocators.test(s) then-- CGEN::emitted_iter_allocators FSET{1}::test BOOL::not
emitted_iter_allocators := emitted_iter_allocators.insert(s);-- CGEN::emitted_iter_allocators CGEN::emitted_iter_allocators FSET{1}::insert
unbox_c + "void* "+res+"() {\n"-- CGEN::unbox_c CODE_FILE::plus CODE_FILE::plus
+ " return OB_ALLOC("+mang(s)+"_frame);\n"-- CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CGEN::mang
+ "}\n";-- CODE_FILE::plus CODE_FILE::plus
end;
return res;
end;
private emit_dispatch_func_table(f:AM_ROUT_DEF) is
-- emit function pointer table for dispatched routines
dispatch_c.uses_sig(f.sig);-- CGEN::dispatch_c CODE_FILE::uses_sig AM_ROUT_DEF::sig
-- first, collect descendents' info. We want to make the smallest
-- table possible, so find the min and max tags needed.
des::=#FLIST{$TP};-- FLIST{1}::create
mintag::=INT::maxint;-- INT::maxint
maxtag::=INT::minint;-- INT::minint
cst:STR; -- Cast to correct function pointer type
gh:FSET{$TP};
fst::=f.sig.tp;-- AM_ROUT_DEF::sig SIG::tp
--#OUT+"Working on Dispatch Table for "+f.sig.str+", tp: "+fst.str+"\n";
typecase fst
when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); -- CGEN::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::des_of
end;
loop t::=gh.elt!;-- FSET{1}::elt!
-- skip fetures coming from partial classes - they cannot be called
-- since partial classes cannot be instantiated
if ~t.is_partial then-- BOOL::not
des:=des.push(t);-- FLIST{1}::push
--tag:INT:=num_tag_for(t);
tag:INT:=tags.get(t);-- CGEN::tags FMAP{2}::get
--#OUT+tag+" --> "+t.str+"\n";
if tag=0 then-- INT::is_eq
--#OUT+"oops, tag for TP "+t.str+" = 0??\n";
else
maxtag:=maxtag.max(tag);-- INT::max
mintag:=mintag.min(tag);-- INT::min
end;
end;
end;
-- comment(dispatch_c,"Dispatch table for "+f.sig.str+" ["+mang(f.sig)+"]");
-- dispatch_c+"\nconst int "+mang(f.sig)+"_offset = "+(-mintag)+";\n";
-- forbid(mang(f.sig)+"_offset");
-- Some of native C compilers do not like returning qualified constant types
-- use the macro here instead of ``const'' to avoid this if needed
decl::="RETURNED_CONST ";
tbl::="RETURNED_CONST ";
cst:="(RETURNED_CONST ";
if ~void(f.sig.ret) then-- AM_ROUT_DEF::sig SIG::ret BOOL::not
decl:=decl+mang(f.sig.ret);-- STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::ret
tbl:=tbl+mang(f.sig.ret);-- STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::ret
cst:=cst+mang(f.sig.ret);-- STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::ret
else
decl:=decl+"void";-- STR::plus
tbl:=tbl+"void";-- STR::plus
cst:=cst+"void";-- STR::plus
end;
decl:=decl+" (*"+mang(f.sig)+"_tbl[])("+mang(f.sig.tp);-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::tp
tbl:=tbl+" (**"+mang(f.sig)+")("+mang(f.sig.tp);-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::tp
cst:=cst+" (*)("+mang(f.sig.tp);-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::tp
if ~void(f.sig.args) then-- AM_ROUT_DEF::sig SIG::args BOOL::not
loop
e::=f.sig.args.elt!;-- AM_ROUT_DEF::sig SIG::args ARRAY{1}::elt!
tbl:=tbl+", "+arg_type_str(e);-- STR::plus STR::plus CGEN::arg_type_str
decl:=decl+", "+arg_type_str(e);-- STR::plus STR::plus CGEN::arg_type_str
cst:=cst+", "+arg_type_str(e);-- STR::plus STR::plus CGEN::arg_type_str
end;
end;
if func_tables then-- CGEN::func_tables
decl:=decl+", struct _func_frame *";-- STR::plus
tbl:=tbl+", struct _func_frame *";-- STR::plus
cst:=cst+", struct _func_frame *";-- STR::plus
end;
decl:=decl+")";-- STR::plus
tbl:=tbl+")="+mang(f.sig)+"_tbl+("+(-mintag)+");\n";-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus STR::plus INT::negate STR::plus
dispatch_c+decl+" = {\n";-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus
cst:=cst+"))";-- STR::plus
-- Manufacture table initialization
-- this is quadratic in number of descendents
loop
i::=mintag.upto!(maxtag);-- INT::upto!
exists:BOOL:=false;
loop
e::=des.elt!;-- FLIST{1}::elt!
--tag:INT:=num_tag_for(e);
tag:INT:=tags.get(e);-- CGEN::tags FMAP{2}::get
real_sig:SIG:=e.ifc.sig_conforming_to(f.sig);-- IFC::sig_conforming_to AM_ROUT_DEF::sig
if ~void(real_sig) and tag=i and tag/=0 then-- BOOL::not INT::is_eq INT::is_eq BOOL::not
exists:=true;
functocall:STR;
make_sure_emitted(real_sig);-- CGEN::make_sure_emitted
functocall:=emit_dispatched_version(real_sig,f.sig);-- CGEN::emit_dispatched_version AM_ROUT_DEF::sig
dispatch_c+' '+cst+functocall;-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if i/=maxtag then dispatch_c+","; end;-- INT::is_eq BOOL::not CGEN::dispatch_c CODE_FILE::plus
comment(dispatch_c,real_sig.str);-- CGEN::dispatch_c SIG::str
dispatch_c+'\n';-- CGEN::dispatch_c CODE_FILE::plus
end;
end;
if ~exists then-- BOOL::not
dispatch_c+"/* "+i+" */"+" NULL";-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if i/=maxtag then dispatch_c+","; end;-- INT::is_eq BOOL::not CGEN::dispatch_c CODE_FILE::plus
dispatch_c+'\n';-- CGEN::dispatch_c CODE_FILE::plus
end;
end;
if mintag>maxtag then-- INT::is_lt
dispatch_c+" NULL /* No descendents found - how odd. */\n";-- CGEN::dispatch_c CODE_FILE::plus
end;
dispatch_c+"};\n"+tbl+"\n";-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
private emit_dispatch_iter_table(f:AM_ROUT_DEF) is
-- emit function pointer table for dispatched iters
-- The entry corresponding to a particular tag contains
-- 2 function pointers: one to a function implementing the
-- iter, and the other to the function that allocates the
-- frame of an appropriate size.
dispatch_c.uses_sig(f.sig);-- CGEN::dispatch_c CODE_FILE::uses_sig AM_ROUT_DEF::sig
-- first, collect descendents' info. We want to make the smallest
-- table possible, so find the min and max tags needed.
des::=#FLIST{$TP};-- FLIST{1}::create
mintag::=INT::maxint;-- INT::maxint
maxtag::=INT::minint;-- INT::minint
cst:STR; -- Cast to correct function pointer type
gh:FSET{$TP};
fst::=f.sig.tp;-- AM_ROUT_DEF::sig SIG::tp
typecase fst
when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); -- CGEN::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::des_of
end;
loop t::=gh.elt!;-- FSET{1}::elt!
-- anything coming from partial classes
if ~t.is_partial then-- BOOL::not
des:=des.push(t);-- FLIST{1}::push
--tag:INT:=num_tag_for(t);
tag:INT:=tags.get(t);-- CGEN::tags FMAP{2}::get
if tag/=0 then-- INT::is_eq BOOL::not
maxtag:=maxtag.max(tag);-- INT::max
mintag:=mintag.min(tag);-- INT::min
end;
end;
end;
comment(dispatch_c,"Iterator dispatch table for "+f.sig.str);-- CGEN::dispatch_c STR::plus AM_ROUT_DEF::sig SIG::str
-- dispatch_c+"\nconst int "+mang(f.sig)+"_offset = "+(-mintag)+";\n";
-- forbid(mang(f.sig)+"_offset");
decl::="RETURNED_CONST "+mang(f.sig)+"_entry ";-- STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus
tbl::="RETURNED_CONST "+mang(f.sig)+"_entry ";-- STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus
cst:="(RETURNED_CONST ";
decl:=decl+mang(f.sig)+"_tbl[]";-- STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus
tbl:=tbl+"*"+mang(f.sig);-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig
if ~void(f.sig.ret) then-- AM_ROUT_DEF::sig SIG::ret BOOL::not
cst:=cst+mang(f.sig.ret);-- STR::plus CGEN::mang AM_ROUT_DEF::sig SIG::ret
else
cst := cst + "void";-- STR::plus
end;
cst:=cst+" (*)("+mang(f.sig)+"_frame";-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus
dispatch_c+"\n"+decl+" = {\n";-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if func_tables then cst:=cst+",struct _func_frame *"; end;-- CGEN::func_tables STR::plus
cst:=cst+"))";-- STR::plus
tbl:=tbl+"="+mang(f.sig)+"_tbl+("+(-mintag)+");\n";-- STR::plus STR::plus CGEN::mang AM_ROUT_DEF::sig STR::plus STR::plus INT::negate STR::plus
alloc_cast ::= "(const void* (*)())";
-- Manufacture table initialization
-- this is quadratic in number of descendents
loop
i::=mintag.upto!(maxtag);-- INT::upto!
exists:BOOL:=false;
loop
e::=des.elt!;-- FLIST{1}::elt!
--tag:INT:=num_tag_for(e);
tag:INT:=tags.get(e);-- CGEN::tags FMAP{2}::get
real_sig:SIG:=e.ifc.sig_conforming_to(f.sig);-- IFC::sig_conforming_to AM_ROUT_DEF::sig
if ~void(tag) and tag=i and tag/=0 then-- BOOL::not INT::is_eq INT::is_eq BOOL::not
exists:=true;
functocall:STR;
make_sure_emitted(real_sig);-- CGEN::make_sure_emitted
-- make sure that typedef for iter frame is
-- placed in the file containing dispatch tables
dispatch_c.uses_iter(real_sig);-- CGEN::dispatch_c CODE_FILE::uses_iter
unbox_c.uses_iter(real_sig);-- CGEN::unbox_c CODE_FILE::uses_iter
functocall:=emit_dispatched_version(real_sig,f.sig);-- CGEN::emit_dispatched_version AM_ROUT_DEF::sig
funcalloc ::=emit_dispatched_allocator(real_sig, f.sig);-- CGEN::emit_dispatched_allocator AM_ROUT_DEF::sig
dispatch_c+" {"+cst+functocall + ", " + -- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
alloc_cast+funcalloc+"}";-- CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if i/=maxtag then dispatch_c+","; end;-- INT::is_eq BOOL::not CGEN::dispatch_c CODE_FILE::plus
comment(dispatch_c,real_sig.str);-- CGEN::dispatch_c SIG::str
dispatch_c+'\n';-- CGEN::dispatch_c CODE_FILE::plus
else
end;
end;
if ~exists then-- BOOL::not
dispatch_c+" {NULL, NULL}";-- CGEN::dispatch_c CODE_FILE::plus
if i/=maxtag then dispatch_c+","; end;-- INT::is_eq BOOL::not CGEN::dispatch_c CODE_FILE::plus
dispatch_c+'\n';-- CGEN::dispatch_c CODE_FILE::plus
end;
end;
if mintag>maxtag then-- INT::is_lt
dispatch_c+" {NULL, NULL} /* No descendents found - how odd. */\n";-- CGEN::dispatch_c CODE_FILE::plus
end;
dispatch_c+"};\n"+tbl+"\n";-- CGEN::dispatch_c CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
end;
private generate_leftovers is
-- Generate code for routines which were inlined but
-- need a definition anyway because they were dispatched
-- or bound.
-- put all leftover routines for which code has been
-- emitted onto emitted_leftovers list
loop
e ::= leftovers.first_elt;-- CGEN::leftovers FSET{1}::first_elt
if ~leftovers.is_elt_nil(e) then-- CGEN::leftovers FSET{1}::is_elt_nil BOOL::not
if ~emitted_leftovers.test(e) then-- CGEN::emitted_leftovers FSET{1}::test BOOL::not
emit_routine(e);-- CGEN::emit_routine
emitted_leftovers:=emitted_leftovers.insert(e);-- CGEN::emitted_leftovers CGEN::emitted_leftovers FSET{1}::insert
end;
leftovers:=leftovers.delete(e);-- CGEN::leftovers CGEN::leftovers FSET{1}::delete
else
break!;
end;
end;
end;
private emit_code(arg:$AM_STMT) is
-- emit code associated with sequence of $AM_STMTs
s1,s2:STR;
loop until!(void(arg));
announce_at(arg.source);-- CGEN::announce_at
typecase arg
when AM_ASSIGN_STMT then emit_am_assign_stmt(arg);-- CGEN::emit_am_assign_stmt
when AM_IF_STMT then emit_am_if_stmt(arg);-- CGEN::emit_am_if_stmt
when AM_LOOP_STMT then emit_am_loop_stmt(arg);-- CGEN::emit_am_loop_stmt
when AM_BREAK_STMT then emit_am_break_stmt(arg);-- CGEN::emit_am_break_stmt
when AM_RETURN_STMT then emit_am_return_stmt(arg); -- CGEN::emit_am_return_stmt
when AM_COMMENT_STMT then emit_am_comment_stmt(arg);-- CGEN::emit_am_comment_stmt
when AM_EXPR_STMT then emit_am_expr_stmt(arg);-- CGEN::emit_am_expr_stmt
when AM_YIELD_STMT then emit_am_yield_stmt(arg);-- CGEN::emit_am_yield_stmt
when AM_CASE_STMT then emit_am_case_stmt(arg);-- CGEN::emit_am_case_stmt
when AM_PRE_STMT then emit_am_pre_stmt(arg);-- CGEN::emit_am_pre_stmt
when AM_POST_STMT then emit_am_post_stmt(arg);-- CGEN::emit_am_post_stmt
when AM_INITIAL_STMT then emit_am_initial_stmt(arg);-- CGEN::emit_am_initial_stmt
when AM_ASSERT_STMT then emit_am_assert_stmt(arg);-- CGEN::emit_am_assert_stmt
when AM_TYPECASE_STMT then emit_am_typecase_stmt(arg);-- CGEN::emit_am_typecase_stmt
when AM_RAISE_STMT then emit_am_raise_stmt(arg);-- CGEN::emit_am_raise_stmt
when AM_INVARIANT_STMT then emit_am_invariant_stmt(arg);-- CGEN::emit_am_invariant_stmt
when AM_PROTECT_STMT then emit_am_protect_stmt(arg);-- CGEN::emit_am_protect_stmt
-- pSather constructs
when AM_ATTACH_STMT then emit_am_attach_stmt(arg);-- CGEN::emit_am_attach_stmt
when AM_LOCK_STMT then emit_am_lock_stmt(arg);-- CGEN::emit_am_lock_stmt
when AM_UNLOCK_STMT then emit_am_unlock_stmt(arg);-- CGEN::emit_am_unlock_stmt
when AM_WITH_NEAR_STMT then emit_am_with_near_stmt(arg);-- CGEN::emit_am_with_near_stmt
when AM_SYNC_STMT then emit_am_sync_stmt(arg);-- CGEN::emit_am_sync_stmt
when AM_PREFETCH_STMT then emit_am_prefetch_stmt(arg);-- CGEN::emit_am_prefetch_stmt
when AM_WAITFOR_STMT then emit_am_waitfor_stmt(arg);-- CGEN::emit_am_waitfor_stmt
else barf("The back-end encountered an improperly"
" translated $AM_STMT: "+SYS::str_for_tp(SYS::tp(arg)));-- CGEN::barf STR::plus SYS::str_for_tp SYS::tp
end;
next::=arg.next;
typecase arg
when AM_LOOP_STMT then -- gets mangled so don't destroy
else SYS::destroy(arg);-- SYS::destroy
end;
arg:=next;
end;
end;
-- make a write to a global variable available to all clusters
broadcast(global:AM_GLOBAL_EXPR)
is
if prog.distributed then-- CGEN::prog PROG::distributed
dummy::=tag_for(global.tp);-- CGEN::tag_for AM_GLOBAL_EXPR::tp
if global.tp.is_immutable then-- AM_GLOBAL_EXPR::tp
if global.tp.is_atomic then-- AM_GLOBAL_EXPR::tp
ndefer("BROADCAST_GLOBAL_VA("+mang(global.tp)+","+emit_am_global_expr(global)+");");-- CGEN::ndefer STR::plus CGEN::mang AM_GLOBAL_EXPR::tp STR::plus STR::plus CGEN::emit_am_global_expr STR::plus
else
ndefer("BROADCAST_GLOBAL_V("+mang(global.tp)+","+emit_am_global_expr(global)+");");-- CGEN::ndefer STR::plus CGEN::mang AM_GLOBAL_EXPR::tp STR::plus STR::plus CGEN::emit_am_global_expr STR::plus
end;
else
ndefer("BROADCAST_GLOBAL_R("+mang(global.tp)+","+emit_am_global_expr(global)+");");-- CGEN::ndefer STR::plus CGEN::mang AM_GLOBAL_EXPR::tp STR::plus STR::plus CGEN::emit_am_global_expr STR::plus
end;
end;
end;
-- detect if an expression would be valid on the left side of
-- an assignment. Basically it checks it we could take the address
-- of this expression in C. This test is needed whenever we assign
-- value types in pSather
is_valid_lhs(e:$AM_EXPR):BOOL is
typecase e
when AM_LOCAL_EXPR then return true;
when AM_GLOBAL_EXPR then return true;
when AM_ATTR_EXPR then return true;
else return false;
end;
end;
-- process an assignment statement. Optimization is checked for
-- the lhs of the assignment. If the node is optimized, then
-- insert the appropriate initialization code. (Only init_optimization
-- is legal here.)
private emit_am_assign_stmt(arg:AM_ASSIGN_STMT) is
lside::=arg.dest;-- AM_ASSIGN_STMT::dest
global:AM_GLOBAL_EXPR:=void;
code_c.uses_tp(lside.tp);-- CGEN::code_c CODE_FILE::uses_tp
s1,sp:STR;
is_attr::=false;
is_immutable::=false;
lside_tp:$TP;
sft::=""; -- * for value types, empty otherwise
typecase lside
when AM_ATTR_EXPR then
tmp::=emit_expr(lside.ob);-- CGEN::emit_expr AM_ATTR_EXPR::ob
tmp:=cast(lside.self_tp,lside.ob.tp,tmp,false);-- CGEN::cast AM_ATTR_EXPR::self_tp AM_ATTR_EXPR::ob
attrname::=mang(lside.at,lside.self_tp);-- CGEN::mang AM_ATTR_EXPR::at AM_ATTR_EXPR::self_tp
lside_tp:=lside.self_tp;-- AM_ATTR_EXPR::self_tp
if prog.psather then-- CGEN::prog PROG::psather
lhsob::=lside.ob;-- AM_ATTR_EXPR::ob
typecase lhsob
when AM_LOCAL_EXPR then
when AM_GLOBAL_EXPR then
else
l::=dec_local(lside.self_tp);-- CGEN::dec_local AM_ATTR_EXPR::self_tp
if lside.self_tp.is_immutable and ~lside.self_tp.is_atomic then-- AM_ATTR_EXPR::self_tp AM_ATTR_EXPR::self_tp BOOL::not
ndefer("VASS_LP("+l+","+mang(lside.self_tp)+","+tmp+");");-- CGEN::ndefer STR::plus STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::self_tp STR::plus STR::plus STR::plus
else
ndefer(l+"="+tmp+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
end;
tmp:=l;
end;
end;
if lside.self_tp.is_immutable then-- AM_ATTR_EXPR::self_tp
if ~prog.psather then -- CGEN::prog PROG::psather BOOL::not
s1:=tmp+"."+attrname; -- STR::plus STR::plus
else
s1:="&"+tmp+','+attrname;-- STR::plus STR::plus STR::plus
sft:="*";
end;
else
s1:=tmp+','+attrname;-- STR::plus STR::plus
end;
is_attr:=true;
sp:=tmp;
when AM_GLOBAL_EXPR then
global:=lside;
s1:=emit_expr(lside);-- CGEN::emit_expr
else
-- A global or a local.
s1:=emit_expr(lside);-- CGEN::emit_expr
end;
if is_attr then
rhs::=cast(arg.dest.tp,arg.src.tp,emit_expr(arg.src),false);-- CGEN::cast AM_ASSIGN_STMT::dest AM_ASSIGN_STMT::src CGEN::emit_expr AM_ASSIGN_STMT::src
if prog.psather then-- CGEN::prog PROG::psather
l::=dec_local(arg.dest.tp);-- CGEN::dec_local AM_ASSIGN_STMT::dest
if arg.src.tp.is_immutable and ~arg.src.tp.is_atomic and is_valid_lhs(arg.src) then-- AM_ASSIGN_STMT::src AM_ASSIGN_STMT::src BOOL::not CGEN::is_valid_lhs AM_ASSIGN_STMT::src
ndefer("VASS_LP("+l.append(",",mang(arg.dest.tp),",",rhs,");"));-- CGEN::ndefer STR::plus STR::append CGEN::mang AM_ASSIGN_STMT::dest
else
ndefer(l.append("=",rhs,";"));-- CGEN::ndefer STR::append
end;
if arg.dest.tp.is_immutable then-- AM_ASSIGN_STMT::dest
if arg.dest.tp.is_atomic then-- AM_ASSIGN_STMT::dest
ndefer("F_VA_WATTR_AA(".append(mang(lside_tp)+sft,",",s1,",",l+");"));-- CGEN::ndefer STR::append CGEN::mang STR::plus STR::plus
else
ndefer("SENDOB("+tag_for(arg.dest.tp)+",&"+l+",WHERE("+sp+"));");-- CGEN::ndefer STR::plus CGEN::tag_for AM_ASSIGN_STMT::dest STR::plus STR::plus STR::plus STR::plus STR::plus
ndefer("F_V_WATTR_PP(".append(mang(lside_tp)+sft,",",s1,",",mang(arg.dest.tp)+","+l+");"));-- CGEN::ndefer STR::append CGEN::mang STR::plus CGEN::mang AM_ASSIGN_STMT::dest STR::plus STR::plus STR::plus
end;
else
ndefer("F_R_WATTR_AA(".append(mang(lside_tp)+sft,",",s1,",",l+");"));-- CGEN::ndefer STR::append CGEN::mang STR::plus STR::plus
end;
else
ndefer("SATTR(".append(s1,",",rhs,");"));-- CGEN::ndefer STR::append
end;
else
is_val_attr_expr::=false;
-- See if it is an expression of the form
-- c:=c.a(...) where c is a value type
-- and a is an attribute assignment expr. If
-- so, do the assignment in place. This isn't
-- trivially generalized to multiple assignments
-- because side-effects must not be observed, and
-- the arguments to later assignments might have
-- a dependance on the earlier assignment.
if lside.tp.is_immutable then
before_dot::=arg.src;-- AM_ASSIGN_STMT::src
typecase before_dot
when AM_VATTR_ASSIGN_EXPR then
arg_before_dot::=before_dot.ob;-- AM_VATTR_ASSIGN_EXPR::ob
typecase arg_before_dot
when AM_LOCAL_EXPR then
if SYS::ob_eq(arg_before_dot,lside) then-- SYS::ob_eq
is_val_attr_expr:=true;
rhs::=cast(before_dot.real_tp,before_dot.val.tp,emit_expr(before_dot.val),false);-- CGEN::cast AM_VATTR_ASSIGN_EXPR::real_tp AM_VATTR_ASSIGN_EXPR::val CGEN::emit_expr AM_VATTR_ASSIGN_EXPR::val
if prog.psather and lside.tp.is_immutable and ~lside.tp.is_atomic then-- CGEN::prog PROG::psather BOOL::not
l::=dec_local(before_dot.val.tp);-- CGEN::dec_local AM_VATTR_ASSIGN_EXPR::val
if before_dot.tp.is_immutable and ~before_dot.tp.is_atomic -- AM_VATTR_ASSIGN_EXPR::tp AM_VATTR_ASSIGN_EXPR::tp
and is_valid_lhs(before_dot.val) then-- BOOL::not CGEN::is_valid_lhs AM_VATTR_ASSIGN_EXPR::val
ndefer("VASS_LP("+l.append(",",mang(before_dot.val.tp),",",rhs,");"));-- CGEN::ndefer STR::plus STR::append CGEN::mang AM_VATTR_ASSIGN_EXPR::val
else
ndefer(l.append("=",rhs,";"));-- CGEN::ndefer STR::append
end;
ndefer("LOCKV(&"+s1+");");-- CGEN::ndefer STR::plus STR::plus
defer(s1.append(".",-- CGEN::defer STR::append
mang(before_dot.at,before_dot.ob.tp)," = ",l,";"));-- CGEN::mang AM_VATTR_ASSIGN_EXPR::at AM_VATTR_ASSIGN_EXPR::ob
defer("UNLOCKV(&"+s1+");");-- CGEN::defer STR::plus STR::plus
else
ndefer(s1.append(".",-- CGEN::ndefer STR::append
mang(before_dot.at,before_dot.ob.tp),-- CGEN::mang AM_VATTR_ASSIGN_EXPR::at AM_VATTR_ASSIGN_EXPR::ob
" = ",rhs,";"));
end;
-- #OUT + "untested did it lhs: " + s1 + '\n';
end;
else
end;
else
end;
end;
if ~is_val_attr_expr then-- BOOL::not
-- Otherwise, do the usual thing.
rhs::=cast(arg.dest.tp,arg.src.tp,emit_expr(arg.src),false);-- CGEN::cast AM_ASSIGN_STMT::dest AM_ASSIGN_STMT::src CGEN::emit_expr AM_ASSIGN_STMT::src
if prog.psather and lside.tp.is_immutable and ~lside.tp.is_atomic then-- CGEN::prog PROG::psather BOOL::not
if ~is_valid_lhs(arg.src) then-- CGEN::is_valid_lhs AM_ASSIGN_STMT::src BOOL::not
l::=dec_local(arg.dest.tp);-- CGEN::dec_local AM_ASSIGN_STMT::dest
ndefer(l.append("=",rhs,";"));-- CGEN::ndefer STR::append
if lside.tp.is_atomic then
ndefer(s1+"="+l+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
else
ndefer("VASS_PL("+s1+","+mang(lside.tp)+","+l+");");-- CGEN::ndefer STR::plus STR::plus STR::plus CGEN::mang STR::plus STR::plus STR::plus
end;
else
if lside.tp.is_atomic then
ndefer(s1+"="+rhs+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
else
ndefer("VASS_PP("+s1+","+mang(lside.tp)+","+rhs+");");-- CGEN::ndefer STR::plus STR::plus STR::plus CGEN::mang STR::plus STR::plus STR::plus
end;
end;
else
ndefer(s1.append(" = ",rhs,";"));-- CGEN::ndefer STR::append
end;
end;
end;
if ~void(global) and prog.psather then-- BOOL::not CGEN::prog PROG::psather
broadcast(global);-- CGEN::broadcast
end;
end;
-- prefetch a value. Works like an assignment statement, but the
-- rhs must be an ATTR_EXPR of a reference class.
-- and the lhs must be an AM_LOCAL_EXPR. Anything else will
-- still work, but it is executed immediatly.
-- In the cases not accepted as special it works like an AM_ASSIGN
private emit_am_prefetch_stmt(arg:AM_PREFETCH_STMT) is
r::=arg.src;-- AM_PREFETCH_STMT::src
l::=arg.dest;-- AM_PREFETCH_STMT::dest
typecase l
when AM_LOCAL_EXPR then
typecase r when AM_ATTR_EXPR then
if ~r.ob.tp.is_immutable then-- AM_ATTR_EXPR::ob BOOL::not
ax::=emit_expr(r.ob);-- CGEN::emit_expr AM_ATTR_EXPR::ob
loc::=emit_expr(l);-- CGEN::emit_expr
pr::=emit_expr(arg.prefetch);-- CGEN::emit_expr AM_PREFETCH_STMT::prefetch
attrname::=mang(r.at,r.self_tp);-- CGEN::mang AM_ATTR_EXPR::at AM_ATTR_EXPR::self_tp
sp::="(*(PREFETCH *)NULL)";
if ~void(current_am_rout_def.specul_prefetch) then-- CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch BOOL::not
sp:=emit_expr(current_am_rout_def.specul_prefetch);-- CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch
end;
if r.tp.is_immutable then-- AM_ATTR_EXPR::tp
if r.tp.is_atomic then-- AM_ATTR_EXPR::tp
ndefer("PRE_VA_RATTR_NA(".append(pr,","+sp,","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));-- CGEN::ndefer STR::append STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::self_tp STR::append
else
ndefer("PRE_V_RATTR_LP(".append(pr,","+sp,","+mang(r.tp)+","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));-- CGEN::ndefer STR::append STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::tp STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::self_tp STR::append
ndefer("RECVOB("+tag_for(r.tp)+",&"+ax+","+loc+"));");-- CGEN::ndefer STR::plus CGEN::tag_for AM_ATTR_EXPR::tp STR::plus STR::plus STR::plus STR::plus STR::plus
end;
else
ndefer("PRE_R_RATTR_NA(".append(pr,","+sp,","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));-- CGEN::ndefer STR::append STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::self_tp STR::append
end;
return;
end;
else end
else end;
-- no special case, make the assignment
emit_am_assign_stmt(#AM_ASSIGN_STMT(arg));-- CGEN::emit_am_assign_stmt AM_ASSIGN_STMT::create
end;
private emit_am_waitfor_stmt(arg:AM_WAITFOR_STMT) is
ndefer("PREFETCH_WAIT("+emit_expr(arg.prefetch)+");");-- CGEN::ndefer STR::plus CGEN::emit_expr AM_WAITFOR_STMT::prefetch STR::plus
end;
private emit_am_if_stmt(arg:AM_IF_STMT) is
s1::=emit_expr(arg.test);-- CGEN::emit_expr AM_IF_STMT::test
ndefer("if (".append(s1,") {")); in;-- CGEN::ndefer STR::append CGEN::in
emit_code(arg.if_true);-- CGEN::emit_code AM_IF_STMT::if_true
move_out; ndefer("}");-- CGEN::move_out CGEN::ndefer
if ~void(arg.if_false) then-- AM_IF_STMT::if_false BOOL::not
ndefer("else {");-- CGEN::ndefer
in;-- CGEN::in
emit_code(arg.if_false);-- CGEN::emit_code AM_IF_STMT::if_false
move_out; ndefer("}");-- CGEN::move_out CGEN::ndefer
end;
end;
private emit_am_loop_stmt(arg:AM_LOOP_STMT) is
mlunl::=manual_loop_unlock;-- CGEN::manual_loop_unlock
manual_loop_unlock:=false;-- CGEN::manual_loop_unlock
outer_loop:STR:=current_loop; -- label to go to after loop-- CGEN::current_loop
current_loop:=mang(arg, current_sig);-- CGEN::current_loop CGEN::mang CGEN::current_sig
outer_loop_ex_nesting:INT:=current_loop_ex_nesting; -- for exception handling-- CGEN::current_loop_ex_nesting
current_loop_ex_nesting:=ex_nesting;-- CGEN::current_loop_ex_nesting CGEN::ex_nesting
fname:STR:=mangler.genother(current_sig); fnamecount::=0; -- otherx ptr-- CGEN::mangler MANGLE::genother CGEN::current_sig
-- contains an association between an iter and all its nested calls, i.e.
-- the calls in its body!, ni, nbi are non-void but empty, upon first
-- invokation, they are being filled in here
ni::=nested_its.get(current_am_rout_def);-- CGEN::nested_its FMAP{2}::get CGEN::current_am_rout_def
nbi::=nested_bits.get(current_am_rout_def); -- same for biters-- CGEN::nested_bits FMAP{2}::get CGEN::current_am_rout_def
-- used by optimizer for array stuff
if ~void(arg.loop_index_var) then -- AM_LOOP_STMT::loop_index_var BOOL::not
arg.loop_index:=emit_am_local_expr(arg.loop_index_var);-- AM_LOOP_STMT::loop_index CGEN::emit_am_local_expr AM_LOOP_STMT::loop_index_var
end;
-- Ivin: do firsts.
arg.has_init_stmt:=false;-- AM_LOOP_STMT::has_init_stmt
if prog.psather then-- CGEN::prog PROG::psather
if arg.bits.size+arg.its.size>0 and ~arg.no_begin_loop and-- AM_LOOP_STMT::bits FLIST{1}::size INT::plus AM_LOOP_STMT::its FLIST{1}::size INT::is_lt AM_LOOP_STMT::no_begin_loop BOOL::not
(~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects-- CGEN::current_sig SIG::is_iter BOOL::not CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or current_sig.get_se_context(prog).has_yield_in_lock)) then-- BOOL::not CGEN::current_sig SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
ndefer("LOOP_BEGIN("+(arg.bits.size+arg.its.size)+")");in;-- CGEN::ndefer STR::plus AM_LOOP_STMT::bits FLIST{1}::size INT::plus AM_LOOP_STMT::its FLIST{1}::size STR::plus CGEN::in
ex_nesting:=ex_nesting+1;-- CGEN::ex_nesting CGEN::ex_nesting INT::plus
current_loop_ex_nesting:=current_loop_ex_nesting+1;-- CGEN::current_loop_ex_nesting CGEN::current_loop_ex_nesting INT::plus
end;
end;
-- outputs block deliminator for the loop enclosing block
if ~void(arg.bits) or ~void(arg.its) or ~void(arg.firsts) or -- AM_LOOP_STMT::bits BOOL::not AM_LOOP_STMT::its BOOL::not AM_LOOP_STMT::firsts BOOL::not
~void(arg.init) then-- AM_LOOP_STMT::init BOOL::not
comment("loop");-- CGEN::comment
arg.has_init_stmt:=true;-- AM_LOOP_STMT::has_init_stmt
ndefer("{"); in;-- CGEN::ndefer CGEN::in
end;
-- loop over its and later bits
if ~void(arg.its) then-- AM_LOOP_STMT::its BOOL::not
loop e::=arg.its.elt!;-- AM_LOOP_STMT::its FLIST{1}::elt!
-- See comment in emit_iter_call_expr for why these must be here.
code_c.uses_sig(e.fun);-- CGEN::code_c CODE_FILE::uses_sig AM_ITER_CALL_EXPR::fun
code_c.uses_iter(e.fun);-- CGEN::code_c CODE_FILE::uses_iter AM_ITER_CALL_EXPR::fun
if ~e.fun.is_builtin then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin BOOL::not
if ~void(ni) then-- BOOL::not
-- inside an iter, so nested frames must be
-- placed in this frame instead of as locals.
-- make sure same nested iter found only once
assert ~ni.contains(e);-- FLIST{1}::contains BOOL::not
ni:=ni.push(e);-- FLIST{1}::push
mangler.force_mangle(e,"frame->nested"-- CGEN::mangler MANGLE::force_mangle
+ni.size,current_sig);-- STR::plus FLIST{1}::size CGEN::current_sig
else -- void(ni)
comment("Frame for call to "+e.fun.str); -- CGEN::comment STR::plus AM_ITER_CALL_EXPR::fun SIG::str
end;
defer_newline;-- CGEN::defer_newline
if arg.has_yield then-- AM_LOOP_STMT::has_yield
if void(ni) then
ndefer(mang(e.fun)+"_frame ");-- CGEN::ndefer CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus
end;
if ~(~void(ni) and e.fun.tp.is_abstract) then-- BOOL::not AM_ITER_CALL_EXPR::fun SIG::tp BOOL::not
defer(mang(e,current_sig));-- CGEN::defer CGEN::mang CGEN::current_sig
end;
if ~e.fun.tp.is_abstract then-- AM_ITER_CALL_EXPR::fun SIG::tp BOOL::not
ndefer(" = OB_ALLOC("+mang(e.fun)+"_frame);");-- CGEN::ndefer STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus
else
defer(";");-- CGEN::defer
end;
else -- ~arg.has_yield
-- at this point iter which are defined on the stack are being
-- handled.
tname::=fname+'_'+fnamecount; -- e.g. other1_0-- STR::plus STR::plus
fnamecount:=fnamecount+1;-- INT::plus
if e.fun.tp.is_abstract then-- AM_ITER_CALL_EXPR::fun SIG::tp
if void(ni) then
ndefer(mang(e.fun)+"_frame ");-- CGEN::ndefer CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus
ndefer(mang(e,current_sig)+";"); -- CGEN::ndefer CGEN::mang CGEN::current_sig STR::plus
end;
else -- ~e.fun.tp.is_abstract
defer("struct "+mang(e.fun)-- CGEN::defer STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun
+"_frame_struct "+tname+";\n");-- STR::plus STR::plus STR::plus
if void(ni) then
defer(mang(e.fun)+"_frame ");-- CGEN::defer CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus
defer(mang(e,current_sig)+" = &"+tname+';');-- CGEN::defer CGEN::mang CGEN::current_sig STR::plus STR::plus STR::plus
end;
end;
end;
else -- e.fun.is_builtin
-- assert(void(e.uniq));
if void(e.uniq) then-- AM_ITER_CALL_EXPR::uniq
e.uniq:=mang(builtin_cntr,current_sig)+"_";-- AM_ITER_CALL_EXPR::uniq CGEN::builtin_cntr CGEN::current_sig STR::plus
end;
if ~void(ni) then-- BOOL::not
-- inside an iter, so nested frames must be
-- placed in this frame instead of as locals.
-- make sure same nested iter found only once
assert ~ni.contains(e);-- FLIST{1}::contains BOOL::not
ni:=ni.push(e);-- FLIST{1}::push
mangler.force_mangle(e,"frame->nested"-- CGEN::mangler MANGLE::force_mangle
+ni.size,current_sig);-- STR::plus FLIST{1}::size CGEN::current_sig
end;
if ~current_sig.is_iter then-- CGEN::current_sig SIG::is_iter BOOL::not
ndefer("BOOL "+"f_"+e.uniq+" = TRUE;");-- CGEN::ndefer STR::plus STR::plus AM_ITER_CALL_EXPR::uniq STR::plus
end;
end;
end;
-- for all dispatched iters compute self
-- to be able to determine the tag for dispatch
-- emit loop init stmts
if ~void(arg.init) then -- AM_LOOP_STMT::init BOOL::not
emit_code(arg.init);-- CGEN::emit_code AM_LOOP_STMT::init
arg.init:=void; -- AM_LOOP_STMT::init
end;
loop
d::=arg.its.elt!;-- AM_LOOP_STMT::its FLIST{1}::elt!
if d.fun.tp.is_abstract then-- AM_ITER_CALL_EXPR::fun SIG::tp
abs_frame_cast ::= "("+mang(d.fun)+"_frame) ";-- STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus
-- put self in a local so it isn't called twice
self_ob ::= dec_local(d.fun.tp);-- CGEN::dec_local AM_ITER_CALL_EXPR::fun SIG::tp
the_self ::= emit_expr(d[0].expr);-- CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
-- initialize self for dispatched frame allocation
init_self ::= d.init;-- AM_ITER_CALL_EXPR::init
typecase init_self
when AM_ASSIGN_STMT then
emit_am_assign_stmt(init_self);-- CGEN::emit_am_assign_stmt
else end; -- init_self can be void (because of const hoisting)
ndefer(self_ob.append(" = ",the_self,";"));-- CGEN::ndefer STR::append
if chk_void and ~null_segfaults then-- CGEN::chk_void CGEN::null_segfaults BOOL::not
ndefer("if (".append(self_ob,"==NULL) {"));-- CGEN::ndefer STR::append
in; -- CGEN::in
runtime_error("Dispatched call to "+d.fun.str + " on void self in " + current_function_str); -- CGEN::runtime_error STR::plus AM_ITER_CALL_EXPR::fun SIG::str STR::plus CGEN::current_function_str
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
tag::="TAG";
if prog.distributed then tag:="F_TAG"; end;-- CGEN::prog PROG::distributed
-- ndefer(mang(d,current_sig)+" = "+abs_frame_cast
-- +"(*"+mang(d.fun)+"["+tag+"("+self_ob+")+"
-- +mang(d.fun)+"_offset].alloc_frame)();");
ndefer(mang(d,current_sig)+" = "+abs_frame_cast-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::plus STR::plus
+"(*"+mang(d.fun)+"["+tag+"("+self_ob+")].alloc_frame)();");-- STR::plus STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus STR::plus STR::plus STR::plus STR::plus
end;
end;
-- make pointers to frames which are really on the stack
-- this couldn't be done above because in C all decs
-- must proceed ordinary assignments.
if ~void(ni) then-- BOOL::not
fnamecount:=0;
loop e::=arg.its.elt!;-- AM_LOOP_STMT::its FLIST{1}::elt!
if ~e.fun.is_builtin_iter then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin_iter BOOL::not
if ~arg.has_yield and ~e.fun.tp.is_abstract then-- AM_LOOP_STMT::has_yield BOOL::not AM_ITER_CALL_EXPR::fun SIG::tp BOOL::not
ndefer(mang(e,current_sig)+" = &"+fname-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::plus STR::plus
+'_'+fnamecount+';');-- STR::plus STR::plus STR::plus
fnamecount:=fnamecount+1;-- INT::plus
end;
end;
end;
end;
-- initialize all iter states, e.g. ... ->state=0
loop
it::=arg.its.elt!;-- AM_LOOP_STMT::its FLIST{1}::elt!
if it.init_before_loop then-- AM_ITER_CALL_EXPR::init_before_loop
emit_iter_initialization(it); -- CGEN::emit_iter_initialization
end;
if it.fun.is_builtin then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin
if current_sig.is_iter then ndefer(iter_frame+"f_"+it.uniq+" = TRUE;"); end;-- CGEN::current_sig SIG::is_iter CGEN::iter_frame STR::plus STR::plus AM_ITER_CALL_EXPR::uniq STR::plus
else
ndefer(mang(it,current_sig)+"->state = 0;");-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::plus
end;
end;
elsif ~void(arg.init) then -- AM_LOOP_STMT::init BOOL::not
emit_code(arg.init);-- CGEN::emit_code AM_LOOP_STMT::init
arg.init:=void;-- AM_LOOP_STMT::init
end;
-- Ivin.
if ~void(arg.firsts) then-- AM_LOOP_STMT::firsts BOOL::not
loop
e::=arg.firsts.elt!;-- AM_LOOP_STMT::firsts FLIST{1}::elt!
ndefer (emit_am_local_expr(e)+" = TRUE;");-- CGEN::ndefer CGEN::emit_am_local_expr STR::plus
end
end;
nested_its:=nested_its.insert(current_am_rout_def,ni);-- CGEN::nested_its CGEN::nested_its FMAP{2}::insert CGEN::current_am_rout_def
-- now biters are being treated
if ~void(arg.bits) then -- AM_LOOP_STMT::bits BOOL::not
defer_newline;-- CGEN::defer_newline
comment("Binary copy of bound iterator object for pot. multiple use.");-- CGEN::comment
loop e ::= arg.bits.elt!; -- AM_LOOP_STMT::bits FLIST{1}::elt!
-- distinguish between nested bound iter calls, i.e. biter calls within
-- iter calls and biter calls elsewhere
if ~void(nbi) and current_sig.is_iter then -- BOOL::not CGEN::current_sig SIG::is_iter
-- optimization for later! : first biter does not need to be copied
-- since it already exists as object.
nbi:=nbi.push(e); -- FLIST{1}::push
mangler.force_mangle(e,"frame->nested_biter"-- CGEN::mangler MANGLE::force_mangle
+nbi.size,current_sig);-- STR::plus FLIST{1}::size CGEN::current_sig
name ::= "frame->nested_biter"+nbi.size;-- STR::plus FLIST{1}::size
bnd_iter_expr ::= emit_expr(e.bi);-- CGEN::emit_expr AM_BND_ITER_CALL_EXPR::bi
l ::= mangler.genlocal(current_sig); -- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(e.bi_tp) +' '+l+";";-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_BND_ITER_CALL_EXPR::bi_tp CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
ndefer(l+" = " + bnd_iter_expr+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
ndefer(name+" = GC_malloc(" + l + "->size);" );-- CGEN::ndefer STR::plus STR::plus STR::plus
ndefer(name + " = ("-- CGEN::ndefer
+mang(e.bi_tp)+") memcpy("+name+","+l+","+l+"->size);");-- STR::plus STR::plus CGEN::mang AM_BND_ITER_CALL_EXPR::bi_tp STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
defer_newline;-- CGEN::defer_newline
else
-- biter call not within enclosing iter
bnd_iter_expr ::= emit_expr(e.bi);-- CGEN::emit_expr AM_BND_ITER_CALL_EXPR::bi
l ::= mangler.genlocal(current_sig); -- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(e.bi_tp) +' '+l+";";-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_BND_ITER_CALL_EXPR::bi_tp CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
ndefer(l+" = " + bnd_iter_expr+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
name ::= mang(e,current_sig);-- CGEN::mang CGEN::current_sig
code_c+eol+' '+mang(e.bi_tp) +' '+name+";";-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang AM_BND_ITER_CALL_EXPR::bi_tp CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
ndefer(name+" = GC_malloc(" + l + "->size);" );-- CGEN::ndefer STR::plus STR::plus STR::plus
ndefer(name+" = ("-- CGEN::ndefer
+mang(e.bi_tp)+") memcpy("+name+","+l+","+l+"->size);");-- STR::plus STR::plus CGEN::mang AM_BND_ITER_CALL_EXPR::bi_tp STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
defer_newline;-- CGEN::defer_newline
end;
end;
end;
nested_bits:=nested_bits.insert(current_am_rout_def,nbi);-- CGEN::nested_bits CGEN::nested_bits FMAP{2}::insert CGEN::current_am_rout_def
ndefer("while (1) {");-- CGEN::ndefer
in;-- CGEN::in
emit_code(arg.body);-- CGEN::emit_code AM_LOOP_STMT::body
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
-- Ivin.
if arg.has_init_stmt then-- AM_LOOP_STMT::has_init_stmt
move_out; ndefer("}");-- CGEN::move_out CGEN::ndefer
end;
ndefer(current_loop.append(": ;"));-- CGEN::current_loop STR::append
-- Explicitly free any heap-allocated frames
if arg.has_yield and ~void(arg.its) then-- AM_LOOP_STMT::has_yield AM_LOOP_STMT::its BOOL::not
loop e::=arg.its.elt!;-- AM_LOOP_STMT::its FLIST{1}::elt!
if ~e.fun.is_builtin_iter then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin_iter BOOL::not
ep::=mang(e,current_sig);-- CGEN::mang CGEN::current_sig
if zones then-- CGEN::zones
ndefer("zfree(".append(ep,"); ",ep," = NULL;"));-- CGEN::ndefer STR::append
else
ndefer("GC_free(".append(ep,"); ",ep," = NULL;"));-- CGEN::ndefer STR::append
end
end;
end;
end;
if prog.psather then-- CGEN::prog PROG::psather
if arg.bits.size+arg.its.size>0 and ~arg.no_begin_loop and-- AM_LOOP_STMT::bits FLIST{1}::size INT::plus AM_LOOP_STMT::its FLIST{1}::size INT::is_lt AM_LOOP_STMT::no_begin_loop BOOL::not
(~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects-- CGEN::current_sig SIG::is_iter BOOL::not CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or current_sig.get_se_context(prog).has_yield_in_lock)) then-- BOOL::not CGEN::current_sig SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
move_out;ndefer("LOOP_END");-- CGEN::move_out CGEN::ndefer
ex_nesting:=ex_nesting-1;-- CGEN::ex_nesting CGEN::ex_nesting INT::minus
end;
end;
current_loop:=outer_loop;-- CGEN::current_loop
current_loop_ex_nesting:=outer_loop_ex_nesting;-- CGEN::current_loop_ex_nesting
manual_loop_unlock:=mlunl;-- CGEN::manual_loop_unlock
end;
private emit_am_break_stmt(arg:AM_BREAK_STMT) is
if manual_loop_unlock then ndefer("LOCK_UNLOCK_NOW;"); end;-- CGEN::manual_loop_unlock CGEN::ndefer
pop_exceptions(ex_nesting-current_loop_ex_nesting);-- CGEN::ex_nesting CGEN::current_loop_ex_nesting
ndefer("goto ".append(current_loop,";"));-- CGEN::ndefer STR::append CGEN::current_loop
end;
private pop_exceptions(n:INT) is
-- Pop out n exception levels
case n
when 0 then -- Don't need to take any action
when 1 then ndefer("POP_EXCEPTION1;");-- CGEN::ndefer
else ndefer("POP_EXCEPTION(".append(n.str,");"));-- CGEN::ndefer STR::append INT::str
end;
end;
private emit_am_comment_stmt(arg:AM_COMMENT_STMT) is
ndefer("/* "+arg.comment+" */");-- CGEN::ndefer STR::plus AM_COMMENT_STMT::comment STR::plus
end;
private emit_am_return_stmt(arg:AM_RETURN_STMT) is
if current_sig.is_iter then-- CGEN::current_sig SIG::is_iter
ndefer("frame->state = -1;");-- CGEN::ndefer
end;
if manual_unlock then ndefer("LOCK_UNLOCK_NOW;"); end;-- CGEN::manual_unlock CGEN::ndefer
pop_exceptions(ex_nesting);-- CGEN::ex_nesting
callee_copy_out;-- CGEN::callee_copy_out
if ~void(current_am_rout_def.specul_prefetch) then-- CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch BOOL::not
ndefer("PREFETCH_WAIT("+emit_expr(current_am_rout_def.specul_prefetch)+");");-- CGEN::ndefer STR::plus CGEN::current_am_rout_def AM_ROUT_DEF::specul_prefetch STR::plus
end;
if ~void(arg.val) then-- AM_RETURN_STMT::val BOOL::not
s1::=emit_expr(arg.val);-- CGEN::emit_expr AM_RETURN_STMT::val
ndefer("return ".append(cast(current_sig.ret,arg.val.tp,s1,false),";"));-- CGEN::ndefer STR::append CGEN::current_sig SIG::ret AM_RETURN_STMT::val
else
assert void(current_sig.ret)-- CGEN::current_sig SIG::ret
or current_sig.is_iter;-- CGEN::current_sig SIG::is_iter
ndefer("return;");-- CGEN::ndefer
end;
if indent=1 then saw_outer_return:=true; end;-- CGEN::indent INT::is_eq CGEN::saw_outer_return
end;
callee_copy_out is
-- take care of inout/out args before the function returns
loop i::=1.upto!(current_am_rout_def.size-1);-- INT::upto! CGEN::current_am_rout_def AM_ROUT_DEF::size INT::minus
if current_am_rout_def[i].mode = MODES::inout_mode or-- CGEN::current_am_rout_def AM_ROUT_DEF::aget AM_FORMAL_ARG::mode MODES::inout_mode
current_am_rout_def[i].mode = MODES::out_mode then-- CGEN::current_am_rout_def AM_ROUT_DEF::aget AM_FORMAL_ARG::mode MODES::out_mode
--copy the local back out
if current_am_rout_def.is_iter then-- CGEN::current_am_rout_def AM_ROUT_DEF::is_iter
l ::= current_iter_out_arg_locals.elt!;-- CGEN::current_iter_out_arg_locals FLIST{1}::elt!
ndefer("*"+"frame->" + "arg"+i.str+" = "+-- CGEN::ndefer STR::plus STR::plus STR::plus INT::str STR::plus
"frame->"+mang(l,current_am_rout_def.sig) -- STR::plus STR::plus CGEN::mang CGEN::current_am_rout_def AM_ROUT_DEF::sig
+ ";"); -- STR::plus
else -- normal routine
ndefer("*"+current_arg_list[i]+" = "+-- CGEN::ndefer CGEN::current_arg_list ARRAY{1}::aget STR::plus
mang(current_am_rout_def[i].expr,current_am_rout_def.sig) -- STR::plus CGEN::current_am_rout_def AM_ROUT_DEF::aget AM_FORMAL_ARG::expr CGEN::current_am_rout_def AM_ROUT_DEF::sig
+ ";");-- STR::plus
end;
end;
end;
end;
private emit_am_expr_stmt(arg:AM_EXPR_STMT) is
if ~void(arg.expr) then -- the otpimizer may produce void expr.-- AM_EXPR_STMT::expr BOOL::not
s1::=emit_expr(arg.expr);-- CGEN::emit_expr AM_EXPR_STMT::expr
if ~void(s1) then-- BOOL::not
if ~void(arg.expr.tp) then ndefer("(void) ".append(s1,";")); -- AM_EXPR_STMT::expr BOOL::not CGEN::ndefer STR::append
else ndefer(s1+';');-- CGEN::ndefer STR::plus
end;
end;
end;
end;
private emit_am_yield_stmt(arg:AM_YIELD_STMT) is
ndefer("frame->state = ".append(arg.ret.str,";"));-- CGEN::ndefer STR::append AM_YIELD_STMT::ret INT::str
if prog.psather and (~prog.yields_in_locks or ~options.side_effects-- CGEN::prog PROG::psather CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or current_sig.get_se_context(prog).has_yield_in_lock) then-- BOOL::not CGEN::current_sig SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
ndefer("frame->ex = GET_EXCEPTION_STACK;");-- CGEN::ndefer
end;
callee_copy_out;-- CGEN::callee_copy_out
if ~void(arg.val) then -- AM_YIELD_STMT::val BOOL::not
ndefer("return ".append(-- CGEN::ndefer STR::append
cast(current_sig.ret,arg.val.tp,emit_expr(arg.val),false),";"));-- CGEN::current_sig SIG::ret AM_YIELD_STMT::val CGEN::emit_expr AM_YIELD_STMT::val
else
ndefer("return;");-- CGEN::ndefer
end;
ndefer("state".append(state_counter.str,":;")); -- CGEN::ndefer STR::append CGEN::state_counter INT::str
state_counter:=state_counter+1;-- CGEN::state_counter CGEN::state_counter INT::plus
end;
private emit_am_case_stmt(arg:AM_CASE_STMT) is
targets:ARRAY{ARRAY{STR}};
test:STR:=emit_expr(arg.test);-- CGEN::emit_expr AM_CASE_STMT::test
-- produce C expressions for all target expressions
if ~void(arg.tgts) then-- AM_CASE_STMT::tgts BOOL::not
targets:=#ARRAY{ARRAY{STR}}(arg.tgts.size);-- ARRAY{1}::create AM_CASE_STMT::tgts FLIST{1}::size
loop
i::=targets.ind!;-- ARRAY{1}::ind!
targets[i]:=#ARRAY{STR}(arg.tgts[i].size);-- ARRAY{1}::aset ARRAY{1}::create AM_CASE_STMT::tgts FLIST{1}::aget FLIST{1}::size
loop
j::=targets[i].ind!;-- ARRAY{1}::aget ARRAY{1}::ind!
targets[i][j]:=emit_expr(arg.tgts[i][j]);-- ARRAY{1}::aget ARRAY{1}::aset CGEN::emit_expr AM_CASE_STMT::tgts FLIST{1}::aget FLIST{1}::aget
end;
end;
ndefer("switch (".append(test,") {"));-- CGEN::ndefer STR::append
in;-- CGEN::in
comment("case statement");-- CGEN::comment
loop
i::=targets.ind!;-- ARRAY{1}::ind!
emit_case:BOOL := false;
case_str:STR;
loop
j::=targets[i].ind!;-- ARRAY{1}::aget ARRAY{1}::ind!
-- emit this target only if it has not been emitted
-- before. Can't have duplicate targets in C and
-- there is no particular need for it either, as the
-- first matching one will be always executed.
case_str := "case ";
already_emitted:BOOL:=false;
loop
k ::= 0.upto!(i);-- INT::upto!
loop
l:INT;
if k/=i then-- INT::is_eq BOOL::not
l := targets[k].ind!;-- ARRAY{1}::aget ARRAY{1}::ind!
else
l :=0.upto!(j-1);-- INT::upto! INT::minus
end;
if targets[k][l] = targets[i][j] then-- ARRAY{1}::aget ARRAY{1}::aget STR::is_eq ARRAY{1}::aget ARRAY{1}::aget
already_emitted := true;
end;
end;
end;
if ~already_emitted then-- BOOL::not
case_str := case_str + ",".separate!(targets[i][j]); -- STR::plus STR::separate! ARRAY{1}::aget ARRAY{1}::aget
emit_case := true;
end;
end;
if emit_case then
ndefer(case_str + ": ");-- CGEN::ndefer STR::plus
in; emit_code(arg.stmts[i]); move_out;-- CGEN::in CGEN::emit_code AM_CASE_STMT::stmts FLIST{1}::aget CGEN::move_out
ndefer(" break;");-- CGEN::ndefer
end;
end;
ndefer("default: ;");-- CGEN::ndefer
in;-- CGEN::in
if arg.no_else then-- AM_CASE_STMT::no_else
runtime_error("No applicable target in case statement");-- CGEN::runtime_error
else emit_code(arg.else_stmts);-- CGEN::emit_code AM_CASE_STMT::else_stmts
end;
move_out; move_out;-- CGEN::move_out CGEN::move_out
ndefer("}");-- CGEN::ndefer
else
runtime_error("No applicable target in case statement");-- CGEN::runtime_error
end;
end;
private emit_am_pre_stmt(arg:AM_PRE_STMT) is
if chk_pre then-- CGEN::chk_pre
ndefer("if (!(".append(emit_expr(arg.test),")) {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_PRE_STMT::test
in; runtime_error("Violation of precondition");move_out;-- CGEN::in CGEN::runtime_error CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
end;
private emit_am_post_stmt(arg:AM_POST_STMT) is
if chk_post then-- CGEN::chk_post
ndefer("if (!(".append(emit_expr(arg.test),")) {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_POST_STMT::test
in;-- CGEN::in
runtime_error("Violation of postcondition");-- CGEN::runtime_error
move_out; -- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
end;
private emit_am_initial_stmt(arg:AM_INITIAL_STMT) is
if chk_post then emit_code(arg.stmts); end;-- CGEN::chk_post CGEN::emit_code AM_INITIAL_STMT::stmts
end;
private emit_am_assert_stmt(arg:AM_ASSERT_STMT) is
if chk_assert then-- CGEN::chk_assert
ndefer("if (!(".append(emit_expr(arg.test),")) {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_ASSERT_STMT::test
in; runtime_error("Violation of assertion"); move_out; -- CGEN::in CGEN::runtime_error CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
end;
private emit_am_typecase_stmt(arg:AM_TYPECASE_STMT) is
label:STR;
if arg.has_void_stmts or chk_when then-- AM_TYPECASE_STMT::has_void_stmts CGEN::chk_when
ndefer("if (".append(emit_expr(arg.test),"==NULL) {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_TYPECASE_STMT::test
in;-- CGEN::in
if arg.has_void_stmts then -- AM_TYPECASE_STMT::has_void_stmts
label := mangler.genother(void); -- generate label name-- CGEN::mangler MANGLE::genother
ndefer("goto "+label+";");-- CGEN::ndefer STR::plus STR::plus
else runtime_error("Void object of typecase");-- CGEN::runtime_error
end;
move_out; -- CGEN::move_out
ndefer("} else");-- CGEN::ndefer
end;
emit_typeswitch(arg.test,arg.tgts,arg.stmts);-- CGEN::emit_typeswitch AM_TYPECASE_STMT::test AM_TYPECASE_STMT::tgts AM_TYPECASE_STMT::stmts
if arg.no_else then-- AM_TYPECASE_STMT::no_else
in;-- CGEN::in
runtime_error("No applicable type in typecase");-- CGEN::runtime_error
move_out;-- CGEN::move_out
else
if ~void(label) then ndefer(label+": ;"); end;-- BOOL::not CGEN::ndefer STR::plus
in; emit_code(arg.else_stmts); move_out;-- CGEN::in CGEN::emit_code AM_TYPECASE_STMT::else_stmts CGEN::move_out
end;
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
private emit_am_raise_stmt(arg:AM_RAISE_STMT) is
assert ~void(arg.val);-- AM_RAISE_STMT::val BOOL::not
ndefer("RAISE(".append(-- CGEN::ndefer STR::append
cast(TP_BUILTIN::dollar_ob,arg.val.tp,emit_expr(arg.val),false),-- CGEN::cast TP_BUILTIN::dollar_ob AM_RAISE_STMT::val CGEN::emit_expr AM_RAISE_STMT::val
");"));
end;
private emit_am_invariant_stmt(arg:AM_INVARIANT_STMT) is
if chk_invariant then-- CGEN::chk_invariant
make_sure_emitted(arg.sig);-- CGEN::make_sure_emitted AM_INVARIANT_STMT::sig
if current_sig.is_iter then-- CGEN::current_sig SIG::is_iter
if func_tables then-- CGEN::func_tables
ndefer("if (!".append(mang(arg.sig),"(frame->self,&FF)) {"));-- CGEN::ndefer STR::append CGEN::mang AM_INVARIANT_STMT::sig
else
ndefer("if (!".append(mang(arg.sig),"(frame->self)) {"));-- CGEN::ndefer STR::append CGEN::mang AM_INVARIANT_STMT::sig
end;
else
if func_tables then-- CGEN::func_tables
ndefer("if (!".append(mang(arg.sig),"(self,&FF)) {"));-- CGEN::ndefer STR::append CGEN::mang AM_INVARIANT_STMT::sig
else
ndefer("if (!".append(mang(arg.sig),"(self)) {"));-- CGEN::ndefer STR::append CGEN::mang AM_INVARIANT_STMT::sig
end;
end;
in;-- CGEN::in
runtime_error("Failed invariant ".append(arg.sig.str));-- CGEN::runtime_error STR::append AM_INVARIANT_STMT::sig SIG::str
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
end;
private emit_am_protect_stmt(arg:AM_PROTECT_STMT) is
ndefer("PROTECT_BEGIN");-- CGEN::ndefer
in;-- CGEN::in
ex_nesting:=ex_nesting+1;-- CGEN::ex_nesting CGEN::ex_nesting INT::plus
emit_code(arg.body);-- CGEN::emit_code AM_PROTECT_STMT::body
ex_nesting:=ex_nesting-1;-- CGEN::ex_nesting CGEN::ex_nesting INT::minus
move_out;-- CGEN::move_out
ndefer("PROTECT_WHEN");-- CGEN::ndefer
in;-- CGEN::in
emit_typeswitch(#AM_EXCEPT_EXPR(TP_BUILTIN::dollar_ob),-- CGEN::emit_typeswitch AM_EXCEPT_EXPR::create TP_BUILTIN::dollar_ob
arg.tgts, arg.stmts);-- AM_PROTECT_STMT::tgts AM_PROTECT_STMT::stmts
if ~arg.no_else then-- AM_PROTECT_STMT::no_else BOOL::not
in; emit_code(arg.else_stmts); move_out;-- CGEN::in CGEN::emit_code AM_PROTECT_STMT::else_stmts CGEN::move_out
else
ndefer("RAISE(EXCEPTION);");-- CGEN::ndefer
end;
move_out;-- CGEN::move_out
ndefer("}"); -- Closes type switch-- CGEN::ndefer
move_out;-- CGEN::move_out
ndefer("PROTECT_END");-- CGEN::ndefer
end;
private emit_typeswitch(test_expr: $AM_EXPR, tgts:FLIST{$TP}, stmts:FLIST{$AM_STMT}) is
-- Emit a structure that switches on type. This is used by both
-- protect and typecase statements. The type of an exception
-- expression should be $OB. It stops after emitting the
-- "default:" entry which should then be generated appropriately
-- by the caller, along with an "out;" and closing curly braces.
etp ::= test_expr.tp;
assert etp.is_abstract; -- all others should have been caught
-- possible types of test_expr
-- will be shrunken by those which were emitted
consider: FSET{$TP};
typecase etp
when TP_CLASS then
consider := prog.tp_graph_abs_des.des_of(etp).copy;-- CGEN::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::des_of FSET{1}::copy
end;
test ::= emit_expr(test_expr);-- CGEN::emit_expr
if prog.distributed then-- CGEN::prog PROG::distributed
ndefer("switch (F_TAG("+test+")) {");-- CGEN::ndefer STR::plus STR::plus
else
ndefer("switch (TAG("+test+")) {");-- CGEN::ndefer STR::plus STR::plus
end;
in;-- CGEN::in
if ~void(tgts) then-- BOOL::not
-- avoid repeated array creation
case_arr ::= #ARRAY{$TP}(consider.size); -- big enough to capture all-- ARRAY{1}::create FSET{1}::size
case_num : INT; -- the number of cases to test
loop
i::=tgts.ind!;-- FLIST{1}::ind!
tp::=tgts[i];-- FLIST{1}::aget
this_branch: FSET{$TP};
if tp.is_abstract then
typecase tp
when TP_CLASS then
-- these are subtypes of tp AND test_expr.tp AND not tested already
this_branch := prog.tp_graph_abs_des.-- CGEN::prog PROG::tp_graph_abs_des
des_of(tp).intersect(consider);-- TP_GRAPH_ABS_DES::des_of FSET{1}::intersect
-- CAUTION: ===/\====
-- One should use to_intersect here, but that one is broken !
-- Fix it first !
end;
-- Have to sort it to make canonical ordering
-- to avoid recompilation
case_num := this_branch.size;-- FSET{1}::size
if case_num > 0 then-- INT::is_lt
loop case_arr.set!(this_branch.elt!) end;-- ARRAY{1}::set! FSET{1}::elt!
case_arr.quicksort_range(0, case_num - 1);-- ARRAY{1}::quicksort_range INT::minus
end;
else -- concrete or bound
if consider.test(tp) then-- FSET{1}::test
this_branch := #FSET{$TP}.insert(tp);-- FSET{1}::create FSET{1}::insert
case_num := 1;
case_arr[0] := tp;-- ARRAY{1}::aset
else
case_num := 0
end;
end;
-- only emit code if some descendant was seen
if case_num > 0 then-- INT::is_lt
loop
t ::= case_arr.elt!(0, case_num);-- ARRAY{1}::elt!
ndefer("case "+tag_for(t)+":");-- CGEN::ndefer STR::plus CGEN::tag_for STR::plus
end;
in;-- CGEN::in
emit_code(stmts[i]);-- CGEN::emit_code FLIST{1}::aget
defer(" break;");-- CGEN::defer
move_out;-- CGEN::move_out
consider := consider.to_difference(this_branch); -- forget about these-- FSET{1}::to_difference
-- else emit some warning ?
end;
end;
end;
ndefer("default: ;"); -- CGEN::ndefer
end;
private emit_am_attach_stmt(arg:AM_ATTACH_STMT) is
-- arg_frames:=arg_frames.insert(arg.rout);
-- code_c.uses_layout(#ARG_LAYOUT(arg.rout));
code_c.uses_sig(arg.rout);-- CGEN::code_c CODE_FILE::uses_sig AM_ATTACH_STMT::rout
stmt::="ATTACH("+mang(arg.rout)-- STR::plus CGEN::mang AM_ATTACH_STMT::rout
+", "+cast(TP_BUILTIN::dollar_ob,arg.rout.tp,"self",false)-- STR::plus STR::plus CGEN::cast TP_BUILTIN::dollar_ob AM_ATTACH_STMT::rout SIG::tp
+", "+emit_expr(arg.helper)-- STR::plus STR::plus CGEN::emit_expr AM_ATTACH_STMT::helper
+", "+emit_expr(arg.gate);-- STR::plus STR::plus CGEN::emit_expr AM_ATTACH_STMT::gate
if ~void(arg.at) then-- AM_ATTACH_STMT::at BOOL::not
stmt:=stmt+", "+emit_expr(arg.at);-- STR::plus STR::plus CGEN::emit_expr AM_ATTACH_STMT::at
else
stmt:=stmt+",HERE";-- STR::plus
end;
stmt:=stmt+");";-- STR::plus
ndefer(stmt);-- CGEN::ndefer
end;
private emit_am_lock_stmt(arg:AM_LOCK_STMT) is
if arg.manual_unlock then-- AM_LOCK_STMT::manual_unlock
prog.stat.incr("O: # of locks not put on exception stack");-- CGEN::prog PROG::stat
assert(~manual_unlock);-- CGEN::manual_unlock BOOL::not
manual_unlock:=true;-- CGEN::manual_unlock
manual_loop_unlock:=true;-- CGEN::manual_loop_unlock
end;
branches::=arg.locks.size;-- AM_LOCK_STMT::locks FLIST{1}::size
cols::=0;
loop cols:=cols.max(arg.locks.elt!.size); end;-- INT::max AM_LOCK_STMT::locks FLIST{1}::elt! ARRAY{1}::size
stmt::="DECLARE_LOCK("+branches+","+cols+",0";-- STR::plus STR::plus STR::plus STR::plus
if ~void(arg.else_stmts) then stmt:=stmt+"|LOCK_WITH_ELSE"; end;-- AM_LOCK_STMT::else_stmts BOOL::not STR::plus
if arg.manual_unlock then stmt:=stmt+"|LOCK_NO_STACK"; end;-- AM_LOCK_STMT::manual_unlock STR::plus
stmt:=stmt+")";-- STR::plus
ndefer(stmt);-- CGEN::ndefer
loop
c::=0.up!;-- INT::up!
l::=arg.locks.elt!;-- AM_LOCK_STMT::locks FLIST{1}::elt!
g::=arg.guards.elt!;-- AM_LOCK_STMT::guards FLIST{1}::elt!
if l.size>15 then barf("You cannot have more than 15 locks in one 'when' branch");end;-- ARRAY{1}::size INT::is_lt CGEN::barf
stmt:="";
if ~void(g) then stmt:=stmt+"if("+emit_expr(g)+") {"; end;-- BOOL::not STR::plus STR::plus CGEN::emit_expr STR::plus
loop
ln::=0.up!;-- INT::up!
stmt:=stmt+"ADD_LOCK("+c+","+ln+","+emit_expr(l.elt!)+");";-- STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus CGEN::emit_expr ARRAY{1}::elt! STR::plus
end;
if ~void(g) then stmt:=stmt+" }"; end;-- BOOL::not STR::plus
ndefer(stmt);-- CGEN::ndefer
end;
if ~manual_unlock then ex_nesting:=ex_nesting+1; end;-- CGEN::manual_unlock BOOL::not CGEN::ex_nesting CGEN::ex_nesting INT::plus
ndefer("SELECT_LOCK");-- CGEN::ndefer
loop
stt::=arg.stmts.elt!;-- AM_LOCK_STMT::stmts FLIST{1}::elt!
ndefer("BRANCH("+1.up!+")");-- CGEN::ndefer STR::plus INT::up! STR::plus
in; emit_code(stt); move_out;-- CGEN::in CGEN::emit_code CGEN::move_out
end;
if ~manual_unlock then ex_nesting:=ex_nesting-1; end;-- CGEN::manual_unlock BOOL::not CGEN::ex_nesting CGEN::ex_nesting INT::minus
mul::=manual_unlock;-- CGEN::manual_unlock
manual_unlock:=false;-- CGEN::manual_unlock
manual_loop_unlock:=false;-- CGEN::manual_loop_unlock
if ~void(arg.else_stmts) then-- AM_LOCK_STMT::else_stmts BOOL::not
ndefer("BRANCH_ELSE");-- CGEN::ndefer
in; emit_code(arg.else_stmts); move_out;-- CGEN::in CGEN::emit_code AM_LOCK_STMT::else_stmts CGEN::move_out
end;
if mul then
ndefer("LOCK_END_NO_STACK");-- CGEN::ndefer
else
ndefer("LOCK_END");-- CGEN::ndefer
end;
end;
private emit_am_sync_stmt(arg:AM_SYNC_STMT) is
ndefer("SYNC;");-- CGEN::ndefer
end;
private emit_am_unlock_stmt(arg:AM_UNLOCK_STMT) is
ndefer("/* Should implement unlock checking here! */");-- CGEN::ndefer
ndefer("UNLOCK("+emit_expr(arg.lock_ob)+");");-- CGEN::ndefer STR::plus CGEN::emit_expr AM_UNLOCK_STMT::lock_ob STR::plus
end;
private runtime_error(s:STR) is
-- emit (deferred) code to generate a fatal error at runtime.
ndefer("FATAL(\""+s+"\");");-- CGEN::ndefer STR::plus STR::plus
end;
private emit_args(arg:$AM_CALL_EXPR):ARRAY{STR} is
-- declare auto variables for any subexpressions that
-- can't be in-line; at the moment that means anything
-- which is a call. Anything which might be emitted
-- as a macro (built in functions) need to not have
-- subexpressions as arguments either
subexpr:STR;
res::=#ARRAY{STR}(arg.asize);-- ARRAY{1}::create
sig_args:ARRAY{ARG}; -- formal parameters in the signature
is_ext::=false;
is_ext_fortran::=false;
is_bnd::=false;
is_iter::=false;
might_be_macro::=false;
typecase arg
when AM_EXT_CALL_EXPR then
is_ext:=true;
sig_args := arg.fun.args; -- AM_EXT_CALL_EXPR::fun SIG::args
if arg.ext_tp.kind = TP_KIND::ext_fortran_tp then-- AM_EXT_CALL_EXPR::ext_tp INT::is_eq TP_KIND::ext_fortran_tp
is_ext_fortran := true;
end;
when AM_ROUT_CALL_EXPR then
might_be_macro:=arg.fun.is_builtin;-- AM_ROUT_CALL_EXPR::fun SIG::is_builtin
sig_args := arg.fun.args;-- AM_ROUT_CALL_EXPR::fun SIG::args
when AM_ITER_CALL_EXPR then
might_be_macro:=arg.fun.is_builtin;-- AM_ITER_CALL_EXPR::fun SIG::is_builtin
sig_args := arg.fun.args;-- AM_ITER_CALL_EXPR::fun SIG::args
is_iter:=true;
when AM_BND_ROUT_CALL_EXPR then
sig_args := arg.br_tp.args;-- AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args
is_bnd := true;
when AM_BND_ITER_CALL_EXPR then
sig_args := arg.bi_tp.args; -- AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::args
is_bnd := true;
is_iter:=true;
when AM_ATTR_EXPR then
-- those are macros in psather that need locals as arguments
might_be_macro:=prog.psather;-- CGEN::prog PROG::psather
end; -- bound iters are not implemented yet
-- first, find the last argument which isn't a call
last:INT;
loop last:=(arg.asize-1).downto!(-1);-- INT::minus INT::downto!
while!(last>=0);-- INT::is_lt BOOL::not
if ~void(arg[last]) then-- BOOL::not
e::=arg[last].expr;-- AM_CALL_ARG::expr
typecase e when $AM_CALL_EXPR then break!; else end;
end;
end;
last:=(last+1).min(arg.asize-1);-- INT::plus INT::min INT::minus
-- first emit self. It always has ``in'' mode
if ~is_bnd then-- BOOL::not
if ~is_ext and ~void(arg[0]) then-- BOOL::not BOOL::not
self_expr::=arg[0].expr; -- AM_CALL_ARG::expr
res[0] := emit_expr(self_expr);-- ARRAY{1}::aset CGEN::emit_expr
typecase self_expr
when AM_LOCAL_EXPR then -- locals can't be affected
when $AM_CONST then -- constants can't be affected
if prog.psather and might_be_macro then-- CGEN::prog PROG::psather
subexpr:=res[0];-- ARRAY{1}::aget
res[0]:=dec_local(self_expr.tp);-- ARRAY{1}::aset CGEN::dec_local
ndefer(res[0].append(" = ",subexpr,";"));-- CGEN::ndefer ARRAY{1}::aget STR::append
end;
else
if might_be_macro or last>0 then-- INT::is_lt
subexpr:=res[0];-- ARRAY{1}::aget
res[0]:=dec_local(self_expr.tp);-- ARRAY{1}::aset CGEN::dec_local
ndefer(res[0].append(" = ",subexpr,";"));-- CGEN::ndefer ARRAY{1}::aget STR::append
end;
end;
end;
if arg.asize>1 then-- INT::is_lt
loop i::=1.upto!(arg.asize-1);-- INT::upto! INT::minus
if ~void(arg[i]) then -- this happens in builtin iter_init, non once-- BOOL::not
-- arguments are set to void.
e::=arg[i].expr;-- AM_CALL_ARG::expr
typecase e
when $AM_CONST then
if prog.psather and might_be_macro then -- CGEN::prog PROG::psather
-- even constants have to be in locals,
-- as many builtins need their address.
res[i] := emit_call_arg(arg[i], sig_args[i-1], true, is_ext_fortran);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget INT::minus
else
res[i] := emit_expr(e) -- constants can't be affected-- ARRAY{1}::aset CGEN::emit_expr
end;
when AM_LOCAL_EXPR then
res[i] := emit_call_arg(arg[i], sig_args[i-1], false,is_ext_fortran);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget INT::minus
else
if is_ext_fortran then
-- always pass by reference
res[i] := emit_call_arg(arg[i], sig_args[i-1],true, true);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget INT::minus
elsif might_be_macro or i<last or -- INT::is_lt
SYS::ob_eq(arg[i].mode, MODES::out_mode) or-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
SYS::ob_eq(arg[i].mode, MODES::inout_mode) -- SYS::ob_eq AM_CALL_ARG::mode MODES::inout_mode
then
res[i] := emit_call_arg(arg[i], sig_args[i-1], true, false);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget INT::minus
else
res[i] := emit_expr(e);-- ARRAY{1}::aset CGEN::emit_expr
end;
end;
else
res[i]:="\n#error Internal Sather Compiler error: using hot argument in builtin iter initialization\n";-- ARRAY{1}::aset
end;
end;
end;
else -- bound rout call
loop i::=0.upto!(arg.asize-1);-- INT::upto! INT::minus
e::=arg[i].expr;-- AM_CALL_ARG::expr
typecase e
when $AM_CONST then
res[i] := emit_expr(e) -- constants can't be affected-- ARRAY{1}::aset CGEN::emit_expr
when AM_LOCAL_EXPR then
res[i] := -- ARRAY{1}::aset
emit_call_arg(arg[i], sig_args[i], false, is_ext_fortran);-- CGEN::emit_call_arg ARRAY{1}::aget
else
if is_ext_fortran then
-- always pass by reference
res[i] := emit_call_arg(arg[i], sig_args[i-1],true, true);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget INT::minus
elsif might_be_macro or i<last or -- INT::is_lt
SYS::ob_eq(arg[i].mode, MODES::out_mode) or-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
SYS::ob_eq(arg[i].mode, MODES::inout_mode) then-- SYS::ob_eq AM_CALL_ARG::mode MODES::inout_mode
res[i] := emit_call_arg(arg[i], sig_args[i], true, false);-- ARRAY{1}::aset CGEN::emit_call_arg ARRAY{1}::aget
else
res[i] := emit_expr(e);-- ARRAY{1}::aset CGEN::emit_expr
end;
end;
end;
end;
return res;
end;
emit_call_arg(a:AM_CALL_ARG, sa:ARG, need_local:BOOL, force_reference:BOOL):STR is
res:STR;
se: STR;
se := emit_expr(a.expr);-- CGEN::emit_expr AM_CALL_ARG::expr
if a.mode = MODES::out_mode or -- AM_CALL_ARG::mode MODES::out_mode
a.mode = MODES::inout_mode then-- AM_CALL_ARG::mode MODES::inout_mode
if sa.tp.is_immutable and -- ARG::tp
SYS::ob_eq(a.mode, MODES::out_mode) and-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
a.expr.tp.is_abstract then-- AM_CALL_ARG::expr
-- casting is done after the call!
tmp ::= dec_local(sa.tp); -- CGEN::dec_local ARG::tp
res := dec_local_ptr(sa.tp);-- CGEN::dec_local_ptr ARG::tp
ndefer(res.append(" = &", tmp, ";"));-- CGEN::ndefer STR::append
else
res := dec_local_ptr(a.expr.tp);-- CGEN::dec_local_ptr AM_CALL_ARG::expr
ndefer(res.append(" = &", se,";")); -- CGEN::ndefer STR::append
end;
elsif force_reference then
if need_local then
tmp ::= dec_local(a.expr.tp);-- CGEN::dec_local AM_CALL_ARG::expr
ndefer(tmp.append(" = " + se + ";"));-- CGEN::ndefer STR::append STR::plus STR::plus
res := "&"+tmp;-- STR::plus
else
res := "&"+se;-- STR::plus
end;
else
if need_local then
res := dec_local(a.expr.tp);-- CGEN::dec_local AM_CALL_ARG::expr
ndefer(res.append(" = ", se, ";"));-- CGEN::ndefer STR::append
else
res := se;
end;
end;
return res;
end;
caller_copy_out(ce:$AM_CALL_EXPR, arg_list:ARRAY{STR}) is
-- Update the out/inout arguments in the external call and
-- sometimes out arguments in internal calls (usually done by
-- the callee), to reflect the
-- results of execution (value-result semantics)
res:STR;
arg:AM_CALL_ARG;
sig_arg:ARG;
typecase ce
when AM_EXT_CALL_EXPR then
loop i::= 1.upto!(ce.asize-1);-- INT::upto! AM_EXT_CALL_EXPR::asize INT::minus
ca ::= ce[i];-- AM_EXT_CALL_EXPR::aget
caller_ext_copy_out(ca,ce.fun.args[i-1], arg_list[i]);-- CGEN::caller_ext_copy_out AM_EXT_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARRAY{1}::aget
end;
when AM_ROUT_CALL_EXPR then
loop i::= 1.upto!(ce.asize-1); -- INT::upto! AM_ROUT_CALL_EXPR::asize INT::minus
caller_value_boxing(ce[i], ce.fun.args[i-1], arg_list[i]);-- CGEN::caller_value_boxing AM_ROUT_CALL_EXPR::aget AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARRAY{1}::aget
end;
when AM_ITER_CALL_EXPR then
loop
e::=ce.elt!(1);-- AM_ITER_CALL_EXPR::elt!
fe::=ce.fun.args.elt!;-- AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::elt!
i::=1.up!;-- INT::up!
-- use canonical names for args on the frame
caller_value_boxing(e, fe,(mang(ce,current_sig)+"->"+"arg"+i.str));-- CGEN::caller_value_boxing CGEN::mang CGEN::current_sig STR::plus STR::plus STR::plus INT::str
end;
when AM_BND_ROUT_CALL_EXPR then
loop i::= 0.upto!(ce.asize-1); -- INT::upto! AM_BND_ROUT_CALL_EXPR::asize INT::minus
caller_value_boxing(ce[i], ce.br_tp.args[i], arg_list[i]);-- CGEN::caller_value_boxing AM_BND_ROUT_CALL_EXPR::aget AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args ARRAY{1}::aget ARRAY{1}::aget
end;
end;
end;
need_caller_copy_out(ce:$AM_CALL_EXPR): BOOL is
arg:AM_CALL_ARG;
sig_arg:ARG;
sig_args:ARRAY{ARG};
is_ext:BOOL:=false;
is_bnd:BOOL := false;
typecase ce
when AM_EXT_CALL_EXPR then
sig_args:=ce.fun.args;-- AM_EXT_CALL_EXPR::fun SIG::args
is_ext := true;
when AM_ROUT_CALL_EXPR then
sig_args := ce.fun.args;-- AM_ROUT_CALL_EXPR::fun SIG::args
when AM_ITER_CALL_EXPR then
sig_args := ce.fun.args;-- AM_ITER_CALL_EXPR::fun SIG::args
when AM_BND_ROUT_CALL_EXPR then
sig_args := ce.br_tp.args;-- AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args
is_bnd := true;
when AM_BND_ITER_CALL_EXPR then
sig_args := ce.bi_tp.args;-- AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::args
is_bnd := true;
end;
if ~is_bnd then-- BOOL::not
loop i::= 1.upto!(ce.asize-1); -- INT::upto! INT::minus
arg:= ce[i];
a::=arg.expr;-- AM_CALL_ARG::expr
typecase a when AM_GLOBAL_EXPR then
if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then-- AM_CALL_ARG::mode MODES::out_mode AM_CALL_ARG::mode MODES::inout_mode
return true;
end;
else end;
sig_arg := sig_args[i-1];-- ARRAY{1}::aget INT::minus
if is_ext and arg.mode = MODES::out_mode -- AM_CALL_ARG::mode MODES::out_mode
or arg.mode = MODES::inout_mode then-- AM_CALL_ARG::mode MODES::inout_mode
return true;
end;
if sig_arg.tp.is_immutable and arg.expr.tp.is_abstract and -- ARG::tp AM_CALL_ARG::expr
sig_arg.mode = MODES::out_mode then-- ARG::mode MODES::out_mode
return true;
end;
end;
else -- Bound routines/iters
loop i::= 0.upto!(ce.asize-1); -- INT::upto! INT::minus
arg:= ce[i];
typecase arg when AM_GLOBAL_EXPR then
if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then
return true;
end;
else end;
sig_arg := sig_args[i];-- ARRAY{1}::aget
if sig_arg.tp.is_immutable and arg.expr.tp.is_abstract and -- ARG::tp AM_CALL_ARG::expr
sig_arg.mode = MODES::out_mode then-- ARG::mode MODES::out_mode
return true;
end;
end;
end;
return false;
end;
-- This needs to be fixed to take into account arrays and attributes
caller_value_boxing(arg: AM_CALL_ARG, sig_arg: ARG, arg_str:STR) is
-- Do boxing for out args if needed: actual arg is abstract
-- and formal is value
if sig_arg.tp.is_immutable and SYS::ob_eq(arg.mode, MODES::out_mode) -- ARG::tp SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
and arg.expr.tp.is_abstract then -- AM_CALL_ARG::expr
-- need to cast back out args
local::=cast(arg.expr.tp, sig_arg.tp, "*"+arg_str,false);-- CGEN::cast AM_CALL_ARG::expr ARG::tp STR::plus
ndefer(emit_expr(arg.expr) + " = "+local+';'); -- CGEN::ndefer CGEN::emit_expr AM_CALL_ARG::expr STR::plus STR::plus STR::plus
end;
g::=arg.expr;-- AM_CALL_ARG::expr
typecase g when AM_GLOBAL_EXPR then
broadcast(g);-- CGEN::broadcast
else end;
end;
caller_ext_copy_out(arg: AM_CALL_ARG, sig_arg: ARG, arg_str:STR) is
-- copy out in caller to ensure pass by value/result for
-- external calls. It has to be done here since ext. routines
-- are beyond our control
if arg.mode = MODES::out_mode or arg.mode = MODES::inout_mode then-- AM_CALL_ARG::mode MODES::out_mode AM_CALL_ARG::mode MODES::inout_mode
if arg.expr.tp.is_abstract then-- AM_CALL_ARG::expr
local::=cast(arg.expr.tp, sig_arg.tp, "*"+arg_str,false);-- CGEN::cast AM_CALL_ARG::expr ARG::tp STR::plus
ndefer(emit_expr(arg.expr) + " = "+local+';'); -- CGEN::ndefer CGEN::emit_expr AM_CALL_ARG::expr STR::plus STR::plus STR::plus
else
if arg.expr.tp.is_immutable then-- AM_CALL_ARG::expr
ndefer(emit_expr(arg.expr) + " = *"+arg_str+';');-- CGEN::ndefer CGEN::emit_expr AM_CALL_ARG::expr STR::plus STR::plus STR::plus
else
ndefer("*(" + emit_expr(arg.expr)+") = *"+arg_str+';');-- CGEN::ndefer STR::plus CGEN::emit_expr AM_CALL_ARG::expr STR::plus STR::plus STR::plus
end;
end;
g::=arg.expr;-- AM_CALL_ARG::expr
typecase g when AM_GLOBAL_EXPR then
broadcast(g);-- CGEN::broadcast
else end;
end;
end;
private emit_and_cast_once_args(arce:AM_ITER_CALL_EXPR):ARRAY{STR} is
-- emit args, properly casted for the given routine call
am::=#ARRAY{AM_CALL_ARG}(arce.asize);-- ARRAY{1}::create AM_ITER_CALL_EXPR::asize
loop -- hide all hot (non once) arguments
i::=am.ind!;-- ARRAY{1}::ind!
am[i]:=arce[i];-- ARRAY{1}::aset AM_ITER_CALL_EXPR::aget
if i>0 and ~void(arce.fun.hot) and arce.fun.hot[i-1] then-- INT::is_lt AM_ITER_CALL_EXPR::fun SIG::hot BOOL::not AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
arce[i]:=void;-- AM_ITER_CALL_EXPR::aset
end;
end;
arg_list::=emit_args(arce);-- CGEN::emit_args
loop arce.set!(am.elt!); end;-- AM_ITER_CALL_EXPR::set! ARRAY{1}::elt!
arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],false);-- ARRAY{1}::aset CGEN::cast AM_ITER_CALL_EXPR::fun SIG::tp AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget
loop
i::=1.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
if void(arce.fun.hot) or ~arce.fun.hot[i-1] then-- AM_ITER_CALL_EXPR::fun SIG::hot AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus BOOL::not
if ~(arce.fun.args[i-1].tp.is_immutable and -- AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
SYS::ob_eq(arce[i].mode, MODES::out_mode) and-- SYS::ob_eq AM_ITER_CALL_EXPR::aget AM_CALL_ARG::mode MODES::out_mode
arce[i].expr.tp.is_abstract)-- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
then-- BOOL::not
arg_list[i]:=cast(arce.fun.args[i-1].tp,-- ARRAY{1}::aset CGEN::cast AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
arce[i].expr.tp,arg_list[i],arce.fun.is_builtin);-- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_ITER_CALL_EXPR::fun SIG::is_builtin
end;
-- casting for out args in the opposite direction is done
-- after the call
end;
end;
arce.arg_list:=arg_list;-- AM_ITER_CALL_EXPR::arg_list
return arg_list;
end;
private emit_and_cast_hot_args(arce:AM_ITER_CALL_EXPR):ARRAY{STR} is
if void(arce.fun.hot) then return arce.arg_list; end;-- AM_ITER_CALL_EXPR::fun SIG::hot AM_ITER_CALL_EXPR::arg_list
am::=#ARRAY{AM_CALL_ARG}(arce.asize);-- ARRAY{1}::create AM_ITER_CALL_EXPR::asize
loop -- hide all hot (non once) arguments
i::=am.ind!;-- ARRAY{1}::ind!
am[i]:=arce[i];-- ARRAY{1}::aset AM_ITER_CALL_EXPR::aget
if i>0 and (void(arce.fun.hot) or ~arce.fun.hot[i-1]) then-- INT::is_lt AM_ITER_CALL_EXPR::fun SIG::hot AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus BOOL::not
arce[i]:=void;-- AM_ITER_CALL_EXPR::aset
end;
end;
arce[0]:=void; -- self is never hot-- AM_ITER_CALL_EXPR::aset
arg_list::=emit_args(arce);-- CGEN::emit_args
loop arce.set!(am.elt!); end;-- AM_ITER_CALL_EXPR::set! ARRAY{1}::elt!
arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],arce.fun.is_builtin);-- ARRAY{1}::aset CGEN::cast AM_ITER_CALL_EXPR::fun SIG::tp AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_ITER_CALL_EXPR::fun SIG::is_builtin
loop
i::=1.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
if arce.fun.hot[i-1] then-- AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
if ~(arce.fun.args[i-1].tp.is_immutable and -- AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
SYS::ob_eq(arce[i].mode, MODES::out_mode) and-- SYS::ob_eq AM_ITER_CALL_EXPR::aget AM_CALL_ARG::mode MODES::out_mode
arce[i].expr.tp.is_abstract) -- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
then-- BOOL::not
arg_list[i]:=cast(arce.fun.args[i-1].tp,-- ARRAY{1}::aset CGEN::cast AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
arce[i].expr.tp,arg_list[i],arce.fun.is_builtin);-- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_ITER_CALL_EXPR::fun SIG::is_builtin
end;
arce.arg_list[i]:=arg_list[i];-- AM_ITER_CALL_EXPR::arg_list ARRAY{1}::aset ARRAY{1}::aget
-- casting for out args in the opposite direction is done
-- after the call
end;
end;
return arce.arg_list;-- AM_ITER_CALL_EXPR::arg_list
end;
private emit_and_cast_args(arce:$AM_CALL_EXPR):ARRAY{STR} is
-- emit args, properly casted for the given routine call
sig_args:ARRAY{ARG};
self_tp:$TP; -- self type
arg_list::=emit_args(arce);-- CGEN::emit_args
typecase arce
when AM_ROUT_CALL_EXPR then
arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],arce.fun.is_builtin);-- ARRAY{1}::aset CGEN::cast AM_ROUT_CALL_EXPR::fun SIG::tp AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_ROUT_CALL_EXPR::fun SIG::is_builtin
loop
i::=1.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
if ~(arce.fun.args[i-1].tp.is_immutable and -- AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
SYS::ob_eq(arce[i].mode, MODES::out_mode) and-- SYS::ob_eq AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::mode MODES::out_mode
arce[i].expr.tp.is_abstract)-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
then-- BOOL::not
arg_list[i]:=cast_arg(arce.fun.args[i-1].tp,-- ARRAY{1}::aset CGEN::cast_arg AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
arce[i].expr.tp,arg_list[i], arce.fun.is_builtin, arce[i].mode);-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_ROUT_CALL_EXPR::fun SIG::is_builtin AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::mode
end;
-- casting for out args in the opposite direction is done
-- after the call
end;
when AM_BND_ROUT_CALL_EXPR then
-- arg_list[0]:=cast(arce.br_tp.args[0].tp,arce[0].expr.tp,arg_list[0]);
loop
i::=0.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
if ~(arce.br_tp.args[i].tp.is_immutable and -- AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args ARRAY{1}::aget ARG::tp
SYS::ob_eq(arce.br_tp.args[i].mode, MODES::out_mode) and-- SYS::ob_eq AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args ARRAY{1}::aget ARG::mode MODES::out_mode
arce[i].expr.tp.is_abstract)-- AM_BND_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
then-- BOOL::not
arg_list[i]:=cast_arg(arce.br_tp.args[i].tp,-- ARRAY{1}::aset CGEN::cast_arg AM_BND_ROUT_CALL_EXPR::br_tp TP_ROUT::args ARRAY{1}::aget ARG::tp
arce[i].expr.tp,arg_list[i], false, arce[i].mode);-- AM_BND_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget AM_BND_ROUT_CALL_EXPR::aget AM_CALL_ARG::mode
end;
-- casting for out args in the opposite direction is done
-- after the call
end;
end;
-- iters never get here!
return arg_list;
end;
expand_macro(r:STR,fun:SIG,args:ARRAY{STR},uniq:STR):STR is
return expand_macro(r,fun,args,uniq,"",void);-- CGEN::expand_macro
end;
expand_macro(r:STR,fun:SIG,args:ARRAY{STR},uniq:STR,frame:STR):STR is
return expand_macro(r,fun,args,uniq,frame,void);-- CGEN::expand_macro
end;
expand_macro(r:STR,fun:SIG,args:ARRAY{STR},uniq:STR,frame:STR,loop_index:STR):STR is
res:STR;
i:INT:=0;
loop while!(i<r.size);-- INT::is_lt STR::size
case r[i]-- STR::aget
when '@' then
i:=i+1;-- INT::plus
cast::=false;
tp:$TP;
if r[i]='(' then cast:=true; i:=i+1; end;-- STR::aget CHAR::is_eq INT::plus
case r[i] -- STR::aget
when '0' then
tp:=fun.tp;-- SIG::tp
when '1','2','3','4','5','6','7','8','9' then
l:INT:=r[i].int-'1'.int;-- STR::aget CHAR::int INT::minus CHAR::int
tp:=fun.args[l].tp;-- SIG::args ARRAY{1}::aget ARG::tp
when 'r' then
if void(fun.ret) then-- SIG::ret
barf("@r is undefined for macro ("+r+") in CONFIG for "+fun.str);-- CGEN::barf STR::plus STR::plus STR::plus SIG::str
end;
tp:=fun.ret;-- SIG::ret
when 'P' then
i:=i+1;-- INT::plus
tparams ::= fun.src_tparams;-- SIG::src_tparams
if r[i]<'0' or r[i]>'9' then-- STR::aget CHAR::is_lt STR::aget CHAR::is_lt
barf("@P must be followd by a digit, not by "+r[i]+"\n");-- CGEN::barf STR::plus STR::aget STR::plus
end;
if r[i].int-'0'.int>=tparams.size then-- STR::aget CHAR::int INT::minus CHAR::int INT::is_lt ARRAY{1}::size BOOL::not
barf("@P"+r[i]-- CGEN::barf STR::plus STR::aget
+" out of bounds (macro "+r+", sig "+fun.str+")\n");-- STR::plus STR::plus STR::plus STR::plus SIG::str STR::plus
end;
tp:=tparams[r[i].int-'0'.int];-- ARRAY{1}::aget STR::aget CHAR::int INT::minus CHAR::int
when '@' then
res:=res+" ";-- STR::plus
ru::="";
if manual_loop_unlock then ru:="LOCK_UNLOCK_NOW;"; end;-- CGEN::manual_loop_unlock
case ex_nesting-current_loop_ex_nesting-- CGEN::ex_nesting CGEN::current_loop_ex_nesting
when 0 then res:=res.append(ru,"goto ",current_loop);-- STR::append CGEN::current_loop
when 1 then res:=res.append("do { ",ru,"POP_EXCEPTION1; goto ",current_loop,";} while(0)");-- STR::append CGEN::current_loop
else res:=res.append("do { "+ru,"POP_EXCEPTION(",-- STR::append STR::plus
(ex_nesting-current_loop_ex_nesting).str,-- CGEN::ex_nesting CGEN::current_loop_ex_nesting INT::str
"); goto ",current_loop,";} while(0)");-- CGEN::current_loop
end;
when '.' then
arg_name::="";
i:=i+1;-- INT::plus
loop
while!(r[i].is_alphanum or r[i]='_');-- STR::aget CHAR::is_alphanum STR::aget CHAR::is_eq
arg_name:=arg_name+r[i];-- STR::plus STR::aget
i:=i+1;-- INT::plus
end;
i:=i-1;-- INT::minus
tp:=void;
argi::=#IDENT(arg_name);-- IDENT::create
loop
elt::=fun.tp.impl.elts.elt!;-- SIG::tp IMPL::elts ELT_TBL::elt!
if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then-- ELT::is_attr_reader ELT::is_shared_reader ELT::is_const_reader ELT::name IDENT::is_eq
tp:=elt.ret;-- ELT::ret
break!;
end;
end;
if void(tp) then
barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
else
barf("unknown '@"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::aget STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
if r[i]/='@' then-- STR::aget CHAR::is_eq BOOL::not
if cast then
if ~tp.is_immutable then-- BOOL::not
res:=res+"("+mang(tp)+")";-- STR::plus STR::plus CGEN::mang STR::plus
end;
i:=i+1;-- INT::plus
else
res:=res+mang(tp);-- STR::plus CGEN::mang
end;
end;
when '$' then
i:=i+1;-- INT::plus
case r[i] -- STR::aget
when '0','1','2','3','4','5','6','7','8','9' then
if void(args) then
barf("$n cannot be used in the string '"+r+"', in CONFIG for "+fun.str);-- CGEN::barf STR::plus STR::plus STR::plus SIG::str
end;
l:INT:=r[i].int-'0'.int;-- STR::aget CHAR::int INT::minus CHAR::int
res:=res+args[l];-- STR::plus ARRAY{1}::aget
when '$' then
if i>1 and r[i-2].is_alpha then-- INT::is_lt STR::aget INT::minus CHAR::is_alpha
res:=res+uniq;-- STR::plus
else
res:=res+frame+uniq;-- STR::plus STR::plus
end;
when '#' then
if void(loop_index) then
res:=res+frame+"i_"+uniq;-- STR::plus STR::plus STR::plus
else
res:=res+loop_index; -- frame is included in loop_index-- STR::plus
end;
when '.' then
arg_name::="";
i:=i+1;-- INT::plus
loop
while!(r[i].is_alphanum or r[i]='_');-- STR::aget CHAR::is_alphanum STR::aget CHAR::is_eq
arg_name:=arg_name+r[i];-- STR::plus STR::aget
i:=i+1;-- INT::plus
end;
i:=i-1;-- INT::minus
done::=false;
argi::=#IDENT(arg_name);-- IDENT::create
loop
elt::=fun.tp.impl.elts.elt!;-- SIG::tp IMPL::elts ELT_TBL::elt!
if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then-- ELT::is_attr_reader ELT::is_shared_reader ELT::is_const_reader ELT::name IDENT::is_eq
res:=res+mang(argi,elt.tp);-- STR::plus CGEN::mang ELT::tp
done:=true;
break!;
end;
end;
if ~done then-- BOOL::not
barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
else
barf("unknown '$"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::aget STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
when '%' then
i:=i+1;-- INT::plus
case r[i] -- STR::aget
when '0' then
if fun.tp.is_immutable then -- SIG::tp
if fun.tp.is_atomic then -- SIG::tp
res:=res+'1'; -- STR::plus
else
res:=res+'2';-- STR::plus
end;
else res:=res+'0'; end;-- STR::plus
when '1','2','3','4','5','6','7','8','9' then
l:INT:=r[i].int-'1'.int;-- STR::aget CHAR::int INT::minus CHAR::int
if fun.args[l].tp.is_immutable then-- SIG::args ARRAY{1}::aget ARG::tp
if fun.args[l].tp.is_atomic then-- SIG::args ARRAY{1}::aget ARG::tp
res:=res+'1'; -- STR::plus
else
res:=res+'2'; -- STR::plus
end;
else res:=res+'0'; end;-- STR::plus
when '.' then
arg_name::="";
i:=i+1;-- INT::plus
loop
while!(r[i].is_alphanum or r[i]='_');-- STR::aget CHAR::is_alphanum STR::aget CHAR::is_eq
arg_name:=arg_name+r[i];-- STR::plus STR::aget
i:=i+1;-- INT::plus
end;
i:=i-1;-- INT::minus
done::=false;
argi::=#IDENT(arg_name);-- IDENT::create
loop
elt::=fun.tp.impl.elts.elt!;-- SIG::tp IMPL::elts ELT_TBL::elt!
if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then-- ELT::is_attr_reader ELT::is_shared_reader ELT::is_const_reader ELT::name IDENT::is_eq
if elt.ret.is_immutable then-- ELT::ret
if elt.ret.is_atomic then-- ELT::ret
res:=res+'1'; -- STR::plus
else
res:=res+'2'; -- STR::plus
end;
else res:=res+'0'; end;-- STR::plus
done:=true;
break!;
end;
end;
if ~done then-- BOOL::not
barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
when 'r' then
if void(fun.ret) then-- SIG::ret
barf("%r is undefined for macro ("+r+") in CONFIG for "+fun.str);-- CGEN::barf STR::plus STR::plus STR::plus SIG::str
end;
if fun.ret.is_immutable then -- SIG::ret
if fun.ret.is_atomic then-- SIG::ret
res:=res+'1'; -- STR::plus
else
res:=res+'2';-- STR::plus
end;
else res:=res+'0'; end;-- STR::plus
when 'P' then
i:=i+1;-- INT::plus
tparams ::= fun.src_tparams;-- SIG::src_tparams
if r[i]<'0' or r[i]>'9' then-- STR::aget CHAR::is_lt STR::aget CHAR::is_lt
barf("%P must be followd by a digit, not by "+r[i]+"\n");-- CGEN::barf STR::plus STR::aget STR::plus
end;
if r[i].int-'0'.int>=tparams.size then-- STR::aget CHAR::int INT::minus CHAR::int INT::is_lt ARRAY{1}::size BOOL::not
barf("%P"+r[i]+" out of bounds (macro "+r-- CGEN::barf STR::plus STR::aget STR::plus STR::plus
+", sig "+fun.str+")\n");-- STR::plus STR::plus SIG::str STR::plus
end;
if tparams[r[i].int-'0'.int].is_immutable then -- ARRAY{1}::aget STR::aget CHAR::int INT::minus CHAR::int
if tparams[r[i].int-'0'.int].is_atomic then-- ARRAY{1}::aget STR::aget CHAR::int INT::minus CHAR::int
res:=res+'1'; -- STR::plus
else
res:=res+'2'; -- STR::plus
end;
else
res:=res+'0';-- STR::plus
end;
when '%' then
res:=res+'%';-- STR::plus
else
barf("unknown '%"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");-- CGEN::barf STR::plus STR::aget STR::plus STR::plus SIG::str STR::plus STR::plus STR::plus
end;
else res:=res+r[i];-- STR::plus STR::aget
end;
i:=i+1;-- INT::plus
end;
if void(res) then res:=""; end;
return res;
end;
-- works only for builtin routines, not for iters!
private process_builtin_routs(fun:SIG, arg_list:ARRAY{STR}):STR is
res : STR;
ret : STR;
biname:STR:=void;
prog.stat.incr("B: # of builtin function calls");-- CGEN::prog PROG::stat
if ~prog.distributed and ~void(fun.builtin_info.declare) then -- CGEN::prog PROG::distributed BOOL::not SIG::builtin_info CONFIG_ROUT::declare BOOL::not
loop code_c.uses_extern(fun.builtin_info.declare.elt!+"\n"); end;-- CGEN::code_c CODE_FILE::uses_extern SIG::builtin_info CONFIG_ROUT::declare ARRAY{1}::elt! STR::plus
end;
if prog.distributed and ~void(fun.builtin_info.f_declare) then -- CGEN::prog PROG::distributed SIG::builtin_info CONFIG_ROUT::f_declare BOOL::not
loop code_c.uses_extern(fun.builtin_info.f_declare.elt!+"\n"); end;-- CGEN::code_c CODE_FILE::uses_extern SIG::builtin_info CONFIG_ROUT::f_declare ARRAY{1}::elt! STR::plus
end;
uniq::=mang(builtin_cntr,current_sig)+"_";-- CGEN::builtin_cntr CGEN::current_sig STR::plus
if ~prog.distributed and ~void(fun.builtin_info.var) then-- CGEN::prog PROG::distributed BOOL::not SIG::builtin_info CONFIG_ROUT::var BOOL::not
loop res:=res+eol+' '+fun.builtin_info.var.elt!; end;-- CGEN::eol STR::plus STR::plus SIG::builtin_info CONFIG_ROUT::var ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,fun,arg_list,uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro
res:="";
end;
if prog.distributed and ~void(fun.builtin_info.f_var) then-- CGEN::prog PROG::distributed SIG::builtin_info CONFIG_ROUT::f_var BOOL::not
loop res:=res+eol+' '+fun.builtin_info.f_var.elt!; end;-- CGEN::eol STR::plus STR::plus SIG::builtin_info CONFIG_ROUT::f_var ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,fun,arg_list,uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro
res:="";
end;
exec::=fun.builtin_info.exec;-- SIG::builtin_info CONFIG_ROUT::exec
if prog.distributed then exec:=fun.builtin_info.f_exec; end;-- CGEN::prog PROG::distributed SIG::builtin_info CONFIG_ROUT::f_exec
loop
i::=exec.ind!;-- ARRAY{1}::ind!
if i=exec.size-1 and ~void(fun.ret) then-- INT::is_eq ARRAY{1}::size INT::minus SIG::ret BOOL::not
ret:=exec[i];-- ARRAY{1}::aget
else
if exec[i][0]='#' then-- ARRAY{1}::aget STR::aget CHAR::is_eq
res:=res+'\n'+exec[i]+'\n';-- STR::plus STR::plus ARRAY{1}::aget STR::plus
if debug then-- CGEN::debug
res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";-- STR::plus CGEN::last_lineno STR::plus CGEN::last_file STR::plus
end;
else
res:=res+exec[i]+" ";-- STR::plus ARRAY{1}::aget STR::plus
end;
end;
end;
ndefer(expand_macro(res,fun,arg_list,uniq));-- CGEN::ndefer CGEN::expand_macro
return expand_macro(ret,fun,arg_list,uniq);-- CGEN::expand_macro
end;
-- still to change for disp. bound builtin iters
private emit_call(fun:SIG, arg_list:ARRAY{STR}):STR is
-- assumes all args are appropriately casted already
res:STR;
-- find out if this requires special handling
biname:STR:=void;
if fun.is_builtin_routine then-- SIG::is_builtin_routine
return process_builtin_routs(fun, arg_list);-- CGEN::process_builtin_routs
elsif fun.is_builtin_iter then-- SIG::is_builtin_iter
-- make sure the iter is emitted and generate its call
-- all the call accomp. code is generated by the caller
-- make_sure_emitted(fun); happend in caller
if fun.tp.is_abstract then-- SIG::tp
barf("Dispatched builtin bound iters, soon !")-- CGEN::barf
--( add table etc.. ) res:=mang(fun)+"(";
else
res:=mang(fun)+"(";-- CGEN::mang STR::plus
end;
elsif fun.tp.is_abstract then-- SIG::tp
if fun.is_iter then-- SIG::is_iter
-- abstract biter calls
dtbl_ptr ::= mang(fun);-- CGEN::mang
res := "(*"+dtbl_ptr+"[TAG(f->iter_frame->self)].iter)(";-- STR::plus STR::plus
elsif fun.is_routine then-- SIG::is_routine
self_ob::=dec_local(fun.tp); -- put self in a lcl so it isn't called twice-- CGEN::dec_local SIG::tp
ndefer(self_ob.append(" = ",arg_list[0],";"));-- CGEN::ndefer STR::append ARRAY{1}::aget
arg_list[0]:=self_ob;-- ARRAY{1}::aset
if chk_void and ~null_segfaults then-- CGEN::chk_void CGEN::null_segfaults BOOL::not
ndefer("if (".append(arg_list[0],"==NULL) {"));-- CGEN::ndefer STR::append ARRAY{1}::aget
runtime_error("Dispatched call to "+fun.str -- CGEN::runtime_error STR::plus SIG::str
+ " on void self in " + current_function_str); -- STR::plus CGEN::current_function_str
ndefer("}");-- CGEN::ndefer
end;
if options.stats then ndefer("COUNT_DISPATCH;"); end;-- CGEN::options CS_OPTIONS::stats CGEN::ndefer
if prog.distributed then-- CGEN::prog PROG::distributed
if fun.is_iter and fun.tp.is_bound then -- SIG::is_iter SIG::tp
barf("Distributed biters still at large.");-- CGEN::barf
else
-- res:="(*".append(mang(fun),"[F_TAG(",
-- arg_list[0],")+",mang(fun),"_offset])(");
res:="(*".append(mang(fun),"[F_TAG(",arg_list[0],")])(");-- STR::append CGEN::mang ARRAY{1}::aget
end;
else
-- res:="(*".append(mang(fun),"[TAG(",arg_list[0],")
-- +",mang(fun),"_offset])(");
res:="(*".append(mang(fun),"[TAG(",arg_list[0],")])(");-- STR::append CGEN::mang ARRAY{1}::aget
end;
else
barf("In emit_call, unclassifiable signature : " + fun.str); -- CGEN::barf STR::plus SIG::str
end; -- ends fun.tp.is_abstract
else -- top level
-- must be ordinary call
res:=mang(fun)+"(";-- CGEN::mang STR::plus
end;
code_c.uses_sig(fun);-- CGEN::code_c CODE_FILE::uses_sig
-- emit the argument identifiers.
if ~fun.tp.is_external then-- SIG::tp BOOL::not
res:=res+arg_list[0];-- STR::plus ARRAY{1}::aget
end;
loop
i::=1.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
if fun.tp.is_external then-- SIG::tp
if i=1 then res:=res+arg_list[i];-- INT::is_eq STR::plus ARRAY{1}::aget
else res:=res.append(", ",arg_list[i]);-- STR::append ARRAY{1}::aget
end;
else
res:=res.append(", ",arg_list[i]);-- STR::append ARRAY{1}::aget
end;
end;
if func_tables then-- CGEN::func_tables
if in_bnd_rout_call then-- CGEN::in_bnd_rout_call
res:=res.append(", pFF");-- STR::append
else
res:=res.append(", &FF");-- STR::append
end;
end;
return res.append(")");-- STR::append
end;
-- Some of this is temporary commented out and will have to
-- be restored properly once the header rewrite works.
private emit_stubs_for_forked_call(fun:SIG) is
name::=mang(fun);
-- make header for the marshalling function
-- decs_h+"void "+name+"_stub1(GATE, INT, "+mang(fun.tp);
loop
e::=fun.args.elt!;
-- decs_h+", "+mang(e.tp);
end;
-- decs_h+");\n";
-- make header for the unmarshalling function
-- decs_h+"void "+name+"_stub2("+name+"_arg_frame);\n";
-- stub1: declare and fill in struct, make the call
code_c+"void "+name+"_stub1("+mang(TP_BUILTIN::attach)+" gate, INT at, "+mang(fun.tp)+" self";
loop
e::=fun.args.elt!;
code_c+", "+arg_type_str(e)+" arg"+1.up!;
end;
code_c+") {\n";
code_c+' '+name+"_arg_frame frame = ARG_ALLOC(struct "
+name+"_arg_frame_struct);\n";
code_c+" frame->self = self;\n";
loop
i::=fun.args.ind!;
code_c+" frame->arg"+1.up!+" = arg"+1.up!+";\n";
end;
code_c+" ATTACH("+name+"_stub2, gate, frame, at);\n";
code_c+"}\n\n";
-- stub2: make the call from the struct
code_c+"void "+mang(fun)+"_stub2("+name+"_arg_frame fptr) {\n";
code_c+' '+name+"(fptr->self";
loop
i::=fun.args.ind!;
code_c+", fptr->arg"+1.up!;
end;
code_c+");\n";
code_c+" ARG_FREE(fptr);";
code_c+"}\n\n";
end;
private emit_builtin_iter_call(aice:AM_ITER_CALL_EXPR):STR is
inlined_iter_count:=inlined_iter_count+1;-- CGEN::inlined_iter_count CGEN::inlined_iter_count INT::plus
res : STR;
ret : STR;
biname:STR:=void;
li:STR;
if aice.fun.builtin_info.use_index and aice.use_loop_index then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::use_index AM_ITER_CALL_EXPR::use_loop_index
li:=aice.lp.loop_index;-- AM_ITER_CALL_EXPR::lp AM_LOOP_STMT::loop_index
end;
prog.stat.incr("B: # of builtin iter calls");-- CGEN::prog PROG::stat
if ~prog.distributed and ~void(aice.fun.builtin_info.declare) then -- CGEN::prog PROG::distributed BOOL::not AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::declare BOOL::not
loop code_c.uses_extern(aice.fun.builtin_info.declare.elt!); end;-- CGEN::code_c CODE_FILE::uses_extern AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::declare ARRAY{1}::elt!
end;
if prog.distributed and ~void(aice.fun.builtin_info.f_declare) then -- CGEN::prog PROG::distributed AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_declare BOOL::not
loop code_c.uses_extern(aice.fun.builtin_info.f_declare.elt!); end;-- CGEN::code_c CODE_FILE::uses_extern AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_declare ARRAY{1}::elt!
end;
if prog.distributed then -- CGEN::prog PROG::distributed
if ~void(aice.fun.builtin_info.f_break) then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_break BOOL::not
ndefer(expand_macro("if($#>="+aice.fun.builtin_info.f_break[0]+") @@; ",aice.fun,aice.arg_list,aice.uniq,iter_frame,li));-- CGEN::ndefer CGEN::expand_macro STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_break ARRAY{1}::aget STR::plus AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
end;
else
if ~void(aice.fun.builtin_info.break) then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::break BOOL::not
ndefer(expand_macro("if($#>="+aice.fun.builtin_info.break[0]+") @@; ",aice.fun,aice.arg_list,aice.uniq,iter_frame,li));-- CGEN::ndefer CGEN::expand_macro STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::break ARRAY{1}::aget STR::plus AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
end;
end;
in::=aice.fun.builtin_info.iter;-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::iter
if prog.distributed then-- CGEN::prog PROG::distributed
in:=aice.fun.builtin_info.f_iter;-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_iter
end;
if ~void(in) then-- BOOL::not
loop
i::=in.ind!;-- ARRAY{1}::ind!
if i=in.size-1 and ~void(aice.fun.ret) then-- INT::is_eq ARRAY{1}::size INT::minus AM_ITER_CALL_EXPR::fun SIG::ret BOOL::not
ret:=in[i];-- ARRAY{1}::aget
else
if in[i][0]='#' then-- ARRAY{1}::aget STR::aget CHAR::is_eq
res:=res+'\n'+in[i]+'\n';-- STR::plus STR::plus ARRAY{1}::aget STR::plus
if debug then-- CGEN::debug
res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";-- STR::plus CGEN::last_lineno STR::plus CGEN::last_file STR::plus
end;
else
res:=res+in[i]+" ";-- STR::plus ARRAY{1}::aget STR::plus
end;
end;
end;
if aice.fun.builtin_info.use_index and ~aice.use_loop_index then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::use_index AM_ITER_CALL_EXPR::use_loop_index BOOL::not
res:=res+"$#++;";-- STR::plus
end;
aice.arg_list:=emit_and_cast_hot_args(aice);-- AM_ITER_CALL_EXPR::arg_list CGEN::emit_and_cast_hot_args
ndefer(expand_macro(res,aice.fun,aice.arg_list,aice.uniq,iter_frame,li));-- CGEN::ndefer CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
return expand_macro(ret,aice.fun,aice.arg_list,aice.uniq,iter_frame,li);-- CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
else
if aice.fun.builtin_info.use_index and ~aice.use_loop_index then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::use_index AM_ITER_CALL_EXPR::use_loop_index BOOL::not
ndefer(expand_macro("$#++;",aice.fun,void,aice.uniq,iter_frame));-- CGEN::ndefer CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
end;
return "";
end;
end;
private emit_expr(arg:$AM_EXPR):STR pre ~void(arg) is-- BOOL::not
-- emit code for computing expr if necessary, and return handle
-- to the result.
t::=arg.tp;
if ~void(t) then code_c.uses_tp(t); end;-- BOOL::not CGEN::code_c CODE_FILE::uses_tp
typecase arg
when AM_LOCAL_EXPR then return emit_am_local_expr(arg);-- CGEN::emit_am_local_expr
when AM_ROUT_CALL_EXPR then return emit_rout_call_expr(arg);-- CGEN::emit_rout_call_expr
when AM_ITER_CALL_EXPR then return emit_iter_call_expr(arg);-- CGEN::emit_iter_call_expr
when AM_VOID_CONST then return emit_am_void_const(arg);-- CGEN::emit_am_void_const
when AM_STR_CONST then return emit_am_str_const(arg);-- CGEN::emit_am_str_const
when AM_BOOL_CONST then return emit_am_bool_const(arg);-- CGEN::emit_am_bool_const
when AM_INT_CONST then return emit_am_int_const(arg);-- CGEN::emit_am_int_const
when AM_CHAR_CONST then return emit_am_char_const(arg); -- CGEN::emit_am_char_const
when AM_FLT_CONST then return emit_am_flt_const(arg);-- CGEN::emit_am_flt_const
when AM_FLTD_CONST then return emit_am_fltd_const(arg);-- CGEN::emit_am_fltd_const
when AM_IF_EXPR then return emit_am_if_expr(arg);-- CGEN::emit_am_if_expr
when AM_NEW_EXPR then return emit_am_new_expr(arg);-- CGEN::emit_am_new_expr
when AM_ATTR_EXPR then return emit_am_attr_expr(arg);-- CGEN::emit_am_attr_expr
-- when AM_ASIZE_EXPR then return emit_am_asize_expr(arg);
when AM_VATTR_ASSIGN_EXPR then return emit_am_vattr_assign_expr(arg);-- CGEN::emit_am_vattr_assign_expr
-- when AM_ARR_EXPR then return emit_am_arr_expr(arg);
-- when AM_VARR_ASSIGN_EXPR then return emit_am_varr_assign_expr(arg);
when AM_EXT_CALL_EXPR then return emit_am_ext_call_expr(arg);-- CGEN::emit_am_ext_call_expr
when AM_GLOBAL_EXPR then return emit_am_global_expr(arg);-- CGEN::emit_am_global_expr
when AM_ARRAY_EXPR then return emit_am_array_expr(arg);-- CGEN::emit_am_array_expr
when AM_IS_VOID_EXPR then return emit_am_is_void_expr(arg);-- CGEN::emit_am_is_void_expr
when AM_STMT_EXPR then return emit_am_stmt_expr(arg);-- CGEN::emit_am_stmt_expr
when AM_EXCEPT_EXPR then return emit_am_except_expr(arg);-- CGEN::emit_am_except_expr
when AM_BND_CREATE_EXPR then return emit_am_bnd_create_expr(arg);-- CGEN::emit_am_bnd_create_expr
when AM_BND_ROUT_CALL_EXPR then return emit_am_bnd_rout_call_expr(arg);-- CGEN::emit_am_bnd_rout_call_expr
when AM_BND_ITER_CALL_EXPR then return emit_am_bnd_iter_call_expr(arg); --AJ- -- CGEN::emit_am_bnd_iter_call_expr
-- psather
when AM_HERE_EXPR then return emit_am_here_expr(arg);-- CGEN::emit_am_here_expr
when AM_ANY_EXPR then return emit_am_any_expr(arg);-- CGEN::emit_am_any_expr
when AM_CLUSTER_EXPR then return emit_am_cluster_expr(arg);-- CGEN::emit_am_cluster_expr
when AM_CLUSTER_SIZE_EXPR then return emit_am_cluster_size_expr(arg); -- CGEN::emit_am_cluster_size_expr
when AM_WHERE_EXPR then return emit_am_where_expr(arg);-- CGEN::emit_am_where_expr
when AM_NEAR_EXPR then return emit_am_near_expr(arg);-- CGEN::emit_am_near_expr
when AM_FAR_EXPR then return emit_am_far_expr(arg);-- CGEN::emit_am_far_expr
when AM_AT_EXPR then return emit_am_at_expr(arg);-- CGEN::emit_am_at_expr
-- from here not yet implemented
when AM_ARR_CONST then
barf_at("constant array literals not implemented yet",arg);-- CGEN::barf_at
when AM_INTI_CONST then
barf_at("INTI literals not implemented yet",arg);-- CGEN::barf_at
when AM_FLTI_CONST then
barf_at("FLTI constants not implemented yet",arg);-- CGEN::barf_at
when AM_FLTX_CONST then
barf_at("FLTX literals not implemented yet",arg);-- CGEN::barf_at
when AM_FLTDX_CONST then
barf_at("FLTDX literals not implemented yet",arg);-- CGEN::barf_at
end; -- typecase
barf("Got to end of emit_expr");-- CGEN::barf
return ""; -- because this routine is required to end with a return
end;
private emit_am_local_expr(arg:AM_LOCAL_EXPR):STR is
if current_sig.is_iter then-- CGEN::current_sig SIG::is_iter
return "frame->".append(mang(arg,current_sig));-- STR::append CGEN::mang CGEN::current_sig
else
return mang(arg,current_sig);-- CGEN::mang CGEN::current_sig
end;
end;
private emit_am_void_const(arg:AM_VOID_CONST):STR pre ~void(arg.tp) is-- AM_VOID_CONST::tp BOOL::not
return default_init(arg.tp);-- CGEN::default_init AM_VOID_CONST::tp
end;
private emit_rout_call_expr(arce:AM_ROUT_CALL_EXPR):STR is
if arce.fun.tp.is_abstract then abstract_calls:=abstract_calls+1;-- AM_ROUT_CALL_EXPR::fun SIG::tp CGEN::abstract_calls CGEN::abstract_calls INT::plus
else concrete_calls:=concrete_calls+1;-- CGEN::concrete_calls CGEN::concrete_calls INT::plus
end;
-- constant initializations are not inlined
if in_constant then-- CGEN::in_constant
make_sure_emitted(arce.fun);-- CGEN::make_sure_emitted AM_ROUT_CALL_EXPR::fun
end;
if arce.fun.tp=TP_BUILTIN::sys then-- AM_ROUT_CALL_EXPR::fun SIG::tp TP_BUILTIN::sys
if arce.fun.name=IDENT_BUILTIN::ob_eq_ident then-- AM_ROUT_CALL_EXPR::fun SIG::name IDENT::is_eq IDENT_BUILTIN::ob_eq_ident
-- Make special case for SYS::ob_eq. We want to avoid
-- boxing up value types for the general case (because
-- the args are $OB) because this might be used to
-- compare value types with hash tables. This can't
-- be done where we handle the other special cases
-- because we have to get to it before argument
-- casting (boxing) has occured. Similarly, we want
-- to just compare pointers if both args are in
-- pointers already, something that can't be done if
-- boxing gets involved.
t1::=arce[1].expr.tp;-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
t2::=arce[2].expr.tp;-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
arg1::=emit_expr(arce[1].expr);-- CGEN::emit_expr AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
arg2::=emit_expr(arce[2].expr);-- CGEN::emit_expr AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
if t1.is_immutable and t2.is_immutable then
inlined_value_ob_eq_calls:=inlined_value_ob_eq_calls+1;-- CGEN::inlined_value_ob_eq_calls CGEN::inlined_value_ob_eq_calls INT::plus
if t1=t2 then return value_compare(t1,arg1,arg2);-- CGEN::value_compare
else return "FALSE";
end;
elsif t1.is_immutable or t2.is_immutable
or t1.is_abstract or t2.is_abstract then
-- needs boxed comparison
carg1::=cast(TP_BUILTIN::dollar_ob,t1,arg1,false);-- CGEN::cast TP_BUILTIN::dollar_ob
carg2::=cast(TP_BUILTIN::dollar_ob,t2,arg2,false);-- CGEN::cast TP_BUILTIN::dollar_ob
return "SYSOBEQ(".append(carg1,",",carg2,")");-- STR::append
else
inlined_pointer_ob_eq_calls:=inlined_pointer_ob_eq_calls+1;-- CGEN::inlined_pointer_ob_eq_calls CGEN::inlined_pointer_ob_eq_calls INT::plus
return "(".append(arg1,"==",arg2,")");-- STR::append
end;
elsif arce.fun.name.str="inlined_C" then-- AM_ROUT_CALL_EXPR::fun SIG::name IDENT::str STR::is_eq
argexpr::=arce[1].expr;-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
arg:STR;
typecase argexpr
when AM_STR_CONST then arg:=argexpr.bval;-- AM_STR_CONST::bval
else barf("inlined_C arg something other than STR literal");-- CGEN::barf
end;
res:STR:="";
i::=0;
loop
while!(i<arg.size);-- INT::is_lt STR::size
c::=arg[i];-- STR::aget
case c
when '#' then
var:STR:="";
loop
i:=i+1;-- INT::plus
while!(i<arg.size);-- INT::is_lt STR::size
vc::=arg[i];-- STR::aget
while!(vc.is_alphanum or vc='_');-- CHAR::is_alphanum CHAR::is_eq
var:=var+vc;-- STR::plus
end;
done:BOOL:=false;
loop
-- First check arguments
lcl::=current_am_rout_def.elt!.expr;-- CGEN::current_am_rout_def AM_ROUT_DEF::elt! AM_FORMAL_ARG::expr
if lcl.name.str=var then-- AM_LOCAL_EXPR::name IDENT::str STR::is_eq
res:=res+emit_expr(lcl);-- STR::plus CGEN::emit_expr
done:=true;
break!;
end;
end;
if ~done then-- BOOL::not
loop
-- It wasn't an arg, try for a local
lcl::=current_am_rout_def.locals.elt!;-- CGEN::current_am_rout_def AM_ROUT_DEF::locals FLIST{1}::elt!
if lcl.name.str=var then-- AM_LOCAL_EXPR::name IDENT::str STR::is_eq
res:=res+emit_expr(lcl);-- STR::plus CGEN::emit_expr
done:=true;
break!;
end;
end;
if ~done then-- BOOL::not
barf("Unknown variable '"+var+"' to inline in "+arg);-- CGEN::barf STR::plus STR::plus STR::plus
end;
end;
else
res:=res+c;-- STR::plus
i:=i+1;-- INT::plus
end;
end;
return res;
end;
end;
arg_list::=emit_and_cast_args(arce);-- CGEN::emit_and_cast_args
if need_caller_copy_out(arce) then-- CGEN::need_caller_copy_out
if ~void(arce.fun.ret) then-- AM_ROUT_CALL_EXPR::fun SIG::ret BOOL::not
func_res ::= dec_local(arce.fun.ret);-- CGEN::dec_local AM_ROUT_CALL_EXPR::fun SIG::ret
ndefer( func_res+" = " + emit_call(arce.fun,arg_list) + ';');-- CGEN::ndefer STR::plus STR::plus CGEN::emit_call AM_ROUT_CALL_EXPR::fun STR::plus
caller_copy_out(arce, arg_list);-- CGEN::caller_copy_out
return func_res;
else
-- no result is needed
ndefer(emit_call(arce.fun,arg_list)+';');-- CGEN::ndefer CGEN::emit_call AM_ROUT_CALL_EXPR::fun STR::plus
caller_copy_out(arce, arg_list);-- CGEN::caller_copy_out
return void;
end;
else
return emit_call(arce.fun,arg_list);-- CGEN::emit_call AM_ROUT_CALL_EXPR::fun
end;
end;
private emit_iter_initialization(aice:AM_ITER_CALL_EXPR) is
comment("Initialize once arguments of call to "+aice.fun.str);-- CGEN::comment STR::plus AM_ITER_CALL_EXPR::fun SIG::str
emit_code(aice.init);-- CGEN::emit_code AM_ITER_CALL_EXPR::init
aice.init:=void;-- AM_ITER_CALL_EXPR::init
if aice.fun.is_builtin then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin
assert(~void(aice.uniq));-- AM_ITER_CALL_EXPR::uniq BOOL::not
aice.arg_list:=emit_and_cast_once_args(aice);-- AM_ITER_CALL_EXPR::arg_list CGEN::emit_and_cast_once_args
if ~prog.distributed and ~void(aice.fun.builtin_info.var) and ~current_sig.is_iter then -- CGEN::prog PROG::distributed BOOL::not AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::var BOOL::not CGEN::current_sig SIG::is_iter BOOL::not
res::="";
loop res:=res+eol+" "+aice.fun.builtin_info.var.elt!; end;-- CGEN::eol STR::plus STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::var ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,aice.fun,aice.arg_list,aice.uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq
end;
if prog.distributed and ~void(aice.fun.builtin_info.f_var) and ~current_sig.is_iter then -- CGEN::prog PROG::distributed AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_var BOOL::not CGEN::current_sig SIG::is_iter BOOL::not
res::="";
loop res:=res+eol+" "+aice.fun.builtin_info.f_var.elt!; end;-- CGEN::eol STR::plus STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_var ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,aice.fun,aice.arg_list,aice.uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq
end;
if aice.fun.builtin_info.use_index and ~current_sig.is_iter and ~aice.use_loop_index then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::use_index CGEN::current_sig SIG::is_iter BOOL::not AM_ITER_CALL_EXPR::use_loop_index BOOL::not
code_c:=code_c+expand_macro(eol+"INT $#=0;",aice.fun,void,aice.uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::eol STR::plus AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::uniq
end;
if prog.distributed and ~void(aice.fun.builtin_info.f_temp) then-- CGEN::prog PROG::distributed AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_temp BOOL::not
res::="";
loop res:=res+eol+" "+aice.fun.builtin_info.f_temp.elt!; end;-- CGEN::eol STR::plus STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_temp ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,aice.fun,aice.arg_list,aice.uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq
end;
if ~prog.distributed and ~void(aice.fun.builtin_info.temp) then-- CGEN::prog PROG::distributed BOOL::not AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::temp BOOL::not
res::="";
loop res:=res+eol+" "+aice.fun.builtin_info.temp.elt!; end;-- CGEN::eol STR::plus STR::plus AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::temp ARRAY{1}::elt!
code_c:=code_c+expand_macro(res,aice.fun,aice.arg_list,aice.uniq);-- CGEN::code_c CGEN::code_c CODE_FILE::plus CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq
end;
in::=aice.fun.builtin_info.init;-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::init
if prog.distributed then in:=aice.fun.builtin_info.f_init; end;-- CGEN::prog PROG::distributed AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::f_init
if ~void(in) then-- BOOL::not
res::="";
loop
i::=in.ind!;-- ARRAY{1}::ind!
if in[i][0]='#' then-- ARRAY{1}::aget STR::aget CHAR::is_eq
res:=res+'\n'+in[i]+'\n';-- STR::plus STR::plus ARRAY{1}::aget STR::plus
if debug then-- CGEN::debug
res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";-- STR::plus CGEN::last_lineno STR::plus CGEN::last_file STR::plus
end;
else
res:=res+in[i]+" ";-- STR::plus ARRAY{1}::aget STR::plus
end;
end;
ndefer(expand_macro(res,aice.fun,aice.arg_list,aice.uniq,iter_frame));-- CGEN::ndefer CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::arg_list AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
end;
if aice.fun.builtin_info.use_index and ~aice.use_loop_index then-- AM_ITER_CALL_EXPR::fun SIG::builtin_info CONFIG_ROUT::use_index AM_ITER_CALL_EXPR::use_loop_index BOOL::not
ndefer(expand_macro("$#=0;",aice.fun,void,aice.uniq,iter_frame));-- CGEN::ndefer CGEN::expand_macro AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::uniq CGEN::iter_frame
end;
else
-- for each once argument, copy into frame
loop
i::=aice.ind!;-- AM_ITER_CALL_EXPR::ind!
-- beware the difference in argument indices between
-- aice[] and aice.fun.hot[]!!!
if i=0 then-- INT::is_eq
ndefer(mang(aice,current_sig)-- CGEN::ndefer CGEN::mang CGEN::current_sig
.append("->self = ",emit_expr(aice[i].expr),";"));-- STR::append CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
elsif void(aice.fun.hot) or ~aice.fun.hot[i-1] then-- AM_ITER_CALL_EXPR::fun SIG::hot AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus BOOL::not
ndefer(mang(aice,current_sig).append("->arg",i.str," = ",-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::append INT::str
cast(aice.fun.args[i-1].tp,-- CGEN::cast AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
aice[i].expr.tp,-- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
emit_expr(aice[i].expr),false),-- CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
";"));
end;
end;
end;
end;
private emit_bnd_iter_initialization(biter:AM_BND_ITER_CALL_EXPR) is
-- emit code setting once arguments
comment("Initialize once arguments of call to "+biter.bi_tp.str);-- CGEN::comment STR::plus AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::str
emit_code(biter.init);-- CGEN::emit_code AM_BND_ITER_CALL_EXPR::init
biter.init:=void;-- AM_BND_ITER_CALL_EXPR::init
-- treatment of builtin iters/p.sather comes here
biter_name ::= mang(biter,current_sig);-- CGEN::mang CGEN::current_sig
if void(biter_name) then barf("Unrecognized Sather bound iter name: "
+emit_expr(biter.bi));-- CGEN::barf STR::plus CGEN::emit_expr AM_BND_ITER_CALL_EXPR::bi
end;
loop
i::=biter.ind!;-- AM_BND_ITER_CALL_EXPR::ind!
-- loop over unbnd args and pick out once args
if void(biter.bi_tp.hot) or ~biter.bi_tp.hot[i] then -- AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::hot AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::hot ARRAY{1}::aget BOOL::not
ndefer(biter_name.append("->oncearg"+i+" = ",-- CGEN::ndefer STR::append STR::plus STR::plus
cast(biter.bi_tp.args[i].tp,-- CGEN::cast AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::args ARRAY{1}::aget ARG::tp
biter[i].expr.tp,-- AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
emit_expr(biter[i].expr),false)-- CGEN::emit_expr AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
+";")); -- STR::plus
end;
end;
end;
private emit_iter_call_expr(aice:AM_ITER_CALL_EXPR):STR is
-- The uses_sig and uses_iter calls are made during loop
-- initialization, so they don't happen here. This is important
-- because it is possible to have iterators that are eliminated
-- as the result, for example, of optimizaing away typecase
-- branches.
call_str:STR;
-- constant initializations are not inlined
if in_constant then-- CGEN::in_constant
make_sure_emitted(aice.fun);-- CGEN::make_sure_emitted AM_ITER_CALL_EXPR::fun
end;
s1,res:STR;
if ~void(aice.tp) then-- AM_ITER_CALL_EXPR::tp BOOL::not
-- local variable to hold result (since we have to imbed
-- in a control structure to check for possible termination)
s1:=dec_local_comment(aice.tp,-- CGEN::dec_local_comment AM_ITER_CALL_EXPR::tp
"Holds result of call to "+aice.fun.str);-- STR::plus AM_ITER_CALL_EXPR::fun SIG::str
end;
if aice.fun.is_builtin_iter then-- AM_ITER_CALL_EXPR::fun SIG::is_builtin_iter
if ~aice.init_before_loop then-- AM_ITER_CALL_EXPR::init_before_loop BOOL::not
ndefer("if (".append(iter_frame,"f_",aice.uniq,") {"));-- CGEN::ndefer STR::append CGEN::iter_frame AM_ITER_CALL_EXPR::uniq
in;-- CGEN::in
ndefer(iter_frame+"f_"+aice.uniq+" = FALSE;");-- CGEN::iter_frame STR::plus STR::plus AM_ITER_CALL_EXPR::uniq STR::plus
emit_iter_initialization(aice);-- CGEN::emit_iter_initialization
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
return emit_builtin_iter_call(aice);-- CGEN::emit_builtin_iter_call
end;
-- if first time through, compute once arguments
-- (all once args before any hot args).
if ~aice.init_before_loop then-- AM_ITER_CALL_EXPR::init_before_loop BOOL::not
ndefer("if (".append(mang(aice,current_sig),"->state == 0) {"));-- CGEN::ndefer STR::append CGEN::mang CGEN::current_sig
in;-- CGEN::in
emit_iter_initialization(aice);-- CGEN::emit_iter_initialization
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
-- compute all hot in/inout arguments into frame
if ~void(aice.fun.hot) then-- AM_ITER_CALL_EXPR::fun SIG::hot BOOL::not
-- beware the difference in indices!!!
loop i::=1.upto!(aice.asize-1);-- INT::upto! AM_ITER_CALL_EXPR::asize INT::minus
if aice.fun.hot[i-1] then-- AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget INT::minus
arg_str ::=emit_call_arg(aice[i], aice.fun.args[i-1], false, false);-- CGEN::emit_call_arg AM_ITER_CALL_EXPR::aget AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus
if aice.fun.args[i-1].tp.is_immutable and-- AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp
SYS::ob_eq(aice[i].mode, MODES::out_mode) and-- SYS::ob_eq AM_ITER_CALL_EXPR::aget AM_CALL_ARG::mode MODES::out_mode
aice[i].expr.tp.is_abstract then-- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
-- otherwise casting is done after the call!
ndefer(mang(aice,current_sig).append("->arg",i.str,-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::append INT::str
" = ",
arg_str,
";"));
else
ndefer(mang(aice,current_sig).append("->arg",i.str,-- CGEN::ndefer CGEN::mang CGEN::current_sig STR::append INT::str
" = ",
cast_arg(aice.fun.args[i-1].tp,aice[i].expr.tp,arg_str, false, aice[i].mode),-- CGEN::cast_arg AM_ITER_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::mode
";"));
end;
comment("hot argument");-- CGEN::comment
end;
end;
end;
pro::="";
if func_tables then -- CGEN::func_tables
pro:=",&FF";
end;
if prog.psather and ~aice.lp.no_begin_loop and current_sig.is_iter then-- CGEN::prog PROG::psather AM_ITER_CALL_EXPR::lp AM_LOOP_STMT::no_begin_loop BOOL::not CGEN::current_sig SIG::is_iter
ndefer("RESTORE_CURRENT_EX;");-- CGEN::ndefer
end;
if aice.fun.tp.is_abstract then-- AM_ITER_CALL_EXPR::fun SIG::tp
if chk_void and ~null_segfaults then-- CGEN::chk_void CGEN::null_segfaults BOOL::not
ndefer("if (".append(emit_expr(aice[0].expr),"==NULL) {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
in; -- CGEN::in
runtime_error("Dispatched call to "+aice.fun.str + " on void self in " + current_function_str); -- CGEN::runtime_error STR::plus AM_ITER_CALL_EXPR::fun SIG::str STR::plus CGEN::current_function_str
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
if options.stats then ndefer("COUNT_DISPATCH;"); end;-- CGEN::options CS_OPTIONS::stats CGEN::ndefer
tag::="TAG";
if prog.distributed then tag:="F_TAG"; end;-- CGEN::prog PROG::distributed
if ~void(aice.tp) then-- AM_ITER_CALL_EXPR::tp BOOL::not
ndefer(s1-- CGEN::ndefer
+" = (*"+mang(aice.fun)-- STR::plus STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun
+"["+tag+"("+emit_expr(aice[0].expr)+")].iter)"-- STR::plus STR::plus STR::plus STR::plus CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
+"("+mang(aice,current_sig)+pro+");");-- STR::plus STR::plus STR::plus CGEN::mang CGEN::current_sig STR::plus STR::plus
-- ndefer(s1
-- +" = (*"+mang(aice.fun)
-- +"["+tag+"("+emit_expr(aice[0].expr)+")+"
-- +mang(aice.fun)+"_offset].iter)"
-- +"("+mang(aice,current_sig)+pro+");");
res:=s1;
else
--- ndefer("(*"+mang(aice.fun)+"["+tag+"("+emit_expr(aice[0].expr)+")+"+
--- mang(aice.fun)+"_offset].iter)"+"("+mang(aice,current_sig)+pro+
--- ");");
ndefer("(*"+mang(aice.fun)+"["+tag+"("+emit_expr(aice[0].expr)+-- CGEN::ndefer STR::plus CGEN::mang AM_ITER_CALL_EXPR::fun STR::plus STR::plus STR::plus STR::plus CGEN::emit_expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
")].iter)"+"("+mang(aice,current_sig)+pro+-- STR::plus STR::plus STR::plus CGEN::mang CGEN::current_sig STR::plus
");");-- STR::plus
res:="/* No return value from iter call */";
end;
else -- normal call
if ~void(aice.tp) then-- AM_ITER_CALL_EXPR::tp BOOL::not
ndefer(s1.append(" = ",mang(aice.fun),"(",-- CGEN::ndefer STR::append CGEN::mang AM_ITER_CALL_EXPR::fun
mang(aice,current_sig)+pro,");"));-- CGEN::mang CGEN::current_sig STR::plus
res:=s1;
else
ndefer(mang(aice.fun).append("(",mang(aice,current_sig)+pro,");"));-- CGEN::ndefer CGEN::mang AM_ITER_CALL_EXPR::fun STR::append CGEN::mang CGEN::current_sig STR::plus
res:="/* No return value from iter call */";
end;
end;
if prog.psather and ~aice.lp.no_begin_loop and (~prog.yields_in_locks or ~options.side_effects-- CGEN::prog PROG::psather AM_ITER_CALL_EXPR::lp AM_LOOP_STMT::no_begin_loop BOOL::not CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or aice.fun.get_se_context(prog).has_yield_in_lock) and -- BOOL::not AM_ITER_CALL_EXPR::fun SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
(~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects-- CGEN::current_sig SIG::is_iter BOOL::not CGEN::prog PROG::yields_in_locks BOOL::not CGEN::options CS_OPTIONS::side_effects
or current_sig.get_se_context(prog).has_yield_in_lock)) then-- BOOL::not CGEN::current_sig SIG::get_se_context CGEN::prog SE_CONTEXT::has_yield_in_lock
ndefer("SET_CURRENT_EXCEPTION;");-- CGEN::ndefer
end;
ndefer("if (".append(mang(aice,current_sig),"->state == -1) {"));-- CGEN::ndefer STR::append CGEN::mang CGEN::current_sig
in;-- CGEN::in
if manual_loop_unlock then ndefer("LOCK_UNLOCK_NOW;"); end;-- CGEN::manual_loop_unlock CGEN::ndefer
pop_exceptions(ex_nesting-current_loop_ex_nesting);-- CGEN::ex_nesting CGEN::current_loop_ex_nesting
ndefer("goto ".append(current_loop,";"));-- CGEN::ndefer STR::append CGEN::current_loop
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
-- out args are not updated if iter quits!
if need_caller_copy_out(aice) then-- CGEN::need_caller_copy_out
-- there is always a local for a yielded value,
-- so out args are copied out before the returned
-- temporary is used
caller_copy_out(aice, void); -- CGEN::caller_copy_out
--don't need to pass arg_list - it's canonical for iters;
end;
return res;
end;
private emit_am_str_const(asc:AM_STR_CONST):STR is
s::=asc.bval;-- AM_STR_CONST::bval
name::=string_constants.get(s);-- CGEN::string_constants FMAP{2}::get
if void(name) then
name:=mang(asc);-- CGEN::mang
strings_c+"struct {\n";-- CGEN::strings_c CODE_FILE::plus
strings_c+" OB_HEADER header;\n";-- CGEN::strings_c CODE_FILE::plus
strings_c+" INT asize;\n";-- CGEN::strings_c CODE_FILE::plus
strings_c+" CHAR arr_part["-- CGEN::strings_c
+(s.length+1) -- +1 for Object Center bug-- CODE_FILE::plus CODE_FILE::plus STR::length INT::plus
+"];\n } "+name+" = { ";-- CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
strings_c+"{"+tag_for(TP_BUILTIN::str);-- CGEN::strings_c CODE_FILE::plus CODE_FILE::plus CGEN::tag_for TP_BUILTIN::str
if options.destroy_chk then-- CGEN::options CS_OPTIONS::destroy_chk
strings_c+", 0";-- CGEN::strings_c CODE_FILE::plus
end;
if deterministic then-- CGEN::deterministic
strings_c+", -"+str_count;-- CGEN::strings_c CODE_FILE::plus CGEN::str_count
str_count:=str_count+1;-- CGEN::str_count CGEN::str_count INT::plus
end;
strings_c+"}, "+s.length+", \""+mangler.Cify(s)+"\" };\n";-- CGEN::strings_c CODE_FILE::plus CODE_FILE::plus STR::length CODE_FILE::plus CGEN::mangler MANGLE::Cify CODE_FILE::plus
string_constants:=string_constants.insert(s,name);-- CGEN::string_constants CGEN::string_constants FMAP{2}::insert
strings_c.good_place_to_split;-- CGEN::strings_c CODE_FILE::good_place_to_split
end;
code_c+eol+" extern STR "+name+';';-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
return "((STR) &".append(name,")");-- STR::append
end;
private emit_am_bool_const(arg:AM_BOOL_CONST):STR is
if arg.val then return "TRUE" else return "FALSE" end;-- AM_BOOL_CONST::val
end;
private emit_am_int_const(arg:AM_INT_CONST):STR is
return arg.val.str;-- AM_INT_CONST::val INTI::str
end;
private emit_am_char_const(arg:AM_CHAR_CONST):STR is
return "'".append(mangler.Cify(arg.bval),"\'");-- STR::append CGEN::mangler MANGLE::Cify AM_CHAR_CONST::bval
end;
private emit_am_flt_const(arg:AM_FLT_CONST):STR is
return arg.val.str(8); -- two extra-- AM_FLT_CONST::val RAT::str
end;
private emit_am_fltd_const(arg:AM_FLTD_CONST):STR is
return arg.val.str(17); -- two extra-- AM_FLTD_CONST::val RAT::str
end;
private emit_am_if_expr(arg:AM_IF_EXPR):STR is
res::=dec_local_comment(arg.tp,"local for :? test");-- CGEN::dec_local_comment AM_IF_EXPR::tp
ndefer("if (".append(emit_expr(arg.test),") {"));-- CGEN::ndefer STR::append CGEN::emit_expr AM_IF_EXPR::test
in; ndefer(res.append(" = ",emit_expr(arg.if_true),";")); move_out;-- CGEN::in CGEN::ndefer STR::append CGEN::emit_expr AM_IF_EXPR::if_true CGEN::move_out
ndefer("} else {");-- CGEN::ndefer
in; ndefer(res.append(" = ",emit_expr(arg.if_false),";")); move_out;-- CGEN::in CGEN::ndefer STR::append CGEN::emit_expr AM_IF_EXPR::if_false CGEN::move_out
ndefer("}");-- CGEN::ndefer
return res;
end;
private emit_am_new_expr(arg:AM_NEW_EXPR):STR is
res::=dec_local_comment(arg.tp_at,-- CGEN::dec_local_comment AM_NEW_EXPR::tp_at
"local for ".append(arg.tp_at.str,"::create"));-- STR::append AM_NEW_EXPR::tp_at
if ~void(arg.asz) then-- AM_NEW_EXPR::asz BOOL::not
sizevar::=dec_local(arg.asz.tp);-- CGEN::dec_local AM_NEW_EXPR::asz
s2::=emit_expr(arg.asz);-- CGEN::emit_expr AM_NEW_EXPR::asz
ndefer(sizevar.append(" = ",s2,";"));-- CGEN::ndefer STR::append
ndefer(res.append(" = ",array_allocate(arg.tp_at,sizevar),";"));-- CGEN::ndefer STR::append CGEN::array_allocate AM_NEW_EXPR::tp_at
ndefer(res.append("->asize = ",sizevar,";"));-- CGEN::ndefer STR::append
else ndefer(res.append(" = ",allocate(arg.tp_at),";"));-- CGEN::ndefer STR::append CGEN::allocate AM_NEW_EXPR::tp_at
end;
if arg.tp_at.is_subtype(TP_BUILTIN::dollar_lock) then-- AM_NEW_EXPR::tp_at TP_BUILTIN::dollar_lock
ndefer("INIT_LOCK_HEADER("+res+");");-- CGEN::ndefer STR::plus STR::plus
end;
return res;
end;
private emit_am_attr_expr(arg:AM_ATTR_EXPR):STR is
s1::=emit_expr(arg.ob);-- CGEN::emit_expr AM_ATTR_EXPR::ob
attrname::=mang(arg.at,arg.self_tp);-- CGEN::mang AM_ATTR_EXPR::at AM_ATTR_EXPR::self_tp
if ~prog.distributed then-- CGEN::prog PROG::distributed BOOL::not
sfe::=arg.ob; -- AM_ATTR_EXPR::ob
typecase sfe -- check if we need a local
when AM_LOCAL_EXPR then
when AM_GLOBAL_EXPR then
when AM_ATTR_EXPR then
else
l4::=dec_local(arg.self_tp);-- CGEN::dec_local AM_ATTR_EXPR::self_tp
ndefer(l4+"="+s1+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
s1:=l4;
end;
s1:=cast(arg.self_tp,arg.ob.tp,s1,false);-- CGEN::cast AM_ATTR_EXPR::self_tp AM_ATTR_EXPR::ob
if arg.self_tp.is_immutable then return s1.append(".",attrname);-- AM_ATTR_EXPR::self_tp STR::append
elsif arg.secure then -- AM_ATTR_EXPR::secure
if prog.psather then -- ATTRs is not an lvalue, but we need on in pSather-- CGEN::prog PROG::psather
l::=dec_local(arg.tp);-- CGEN::dec_local AM_ATTR_EXPR::tp
return "(("+l+"=ATTRs(".append(s1,",",attrname,",",default_init(arg.tp),")),"+l+")");-- STR::plus STR::plus STR::append CGEN::default_init AM_ATTR_EXPR::tp STR::plus STR::plus
else
return "ATTRs(".append(s1,",",attrname,",",default_init(arg.tp),")");-- STR::append CGEN::default_init AM_ATTR_EXPR::tp
end;
else return "ATTR(".append(s1,",",attrname,")"); end;-- STR::append
else
-- Warning: we don't check for non atomic value types or secure attr!!!
l::=dec_local(arg.tp);-- CGEN::dec_local AM_ATTR_EXPR::tp
sf::="";
sft::="";
if arg.self_tp.is_immutable then sf:="&"; sft:="*"; end;-- AM_ATTR_EXPR::self_tp
sfe::=arg.ob; -- AM_ATTR_EXPR::ob
typecase sfe -- check if we need a local
when AM_LOCAL_EXPR then
when AM_GLOBAL_EXPR then -- AM_ATTR_EXRP are not safe in pSather
else
l4::=dec_local(arg.self_tp);-- CGEN::dec_local AM_ATTR_EXPR::self_tp
ndefer(l4+"="+s1+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
s1:=l4;
end;
code_c.uses_tp(arg.self_tp);-- CGEN::code_c CODE_FILE::uses_tp AM_ATTR_EXPR::self_tp
code_c.uses_tp(arg.tp);-- CGEN::code_c CODE_FILE::uses_tp AM_ATTR_EXPR::tp
if arg.tp.is_immutable then-- AM_ATTR_EXPR::tp
if arg.tp.is_atomic then-- AM_ATTR_EXPR::tp
ndefer("F_VA_RATTR_NA(".append(l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));-- CGEN::ndefer STR::append CGEN::mang AM_ATTR_EXPR::self_tp STR::plus STR::append STR::plus
else
ndefer("F_V_RATTR_LP(".append(mang(arg.tp)+","+l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));-- CGEN::ndefer STR::append CGEN::mang AM_ATTR_EXPR::tp STR::plus STR::plus CGEN::mang AM_ATTR_EXPR::self_tp STR::plus STR::append STR::plus
ndefer("RECVOB("+tag_for(arg.tp)+",&"+l+",WHERE("+sf+s1+"));");-- CGEN::ndefer STR::plus CGEN::tag_for AM_ATTR_EXPR::tp STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
end;
else
ndefer("F_R_RATTR_NA(".append(l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));-- CGEN::ndefer STR::append CGEN::mang AM_ATTR_EXPR::self_tp STR::plus STR::append STR::plus
end;
return l;
end;
end;
private emit_am_vattr_assign_expr(arg:AM_VATTR_ASSIGN_EXPR):STR is
s1::=emit_expr(arg.ob);-- CGEN::emit_expr AM_VATTR_ASSIGN_EXPR::ob
s2::=mang(arg.at,arg.ob.tp);-- CGEN::mang AM_VATTR_ASSIGN_EXPR::at AM_VATTR_ASSIGN_EXPR::ob
s3::=cast(arg.real_tp,arg.val.tp,emit_expr(arg.val),false);-- CGEN::cast AM_VATTR_ASSIGN_EXPR::real_tp AM_VATTR_ASSIGN_EXPR::val CGEN::emit_expr AM_VATTR_ASSIGN_EXPR::val
res::=dec_local_comment(arg.tp,-- CGEN::dec_local_comment AM_VATTR_ASSIGN_EXPR::tp
"local for value type array assignment");
ndefer(res.append(" = ",s1,";"));-- CGEN::ndefer STR::append
ndefer(res.append(".",s2," = ",s3,";"));-- CGEN::ndefer STR::append
return res;
end;
private emit_am_ext_call_expr(arg:AM_EXT_CALL_EXPR):STR is
arg_list:ARRAY{STR}:=emit_args(arg);-- CGEN::emit_args
extern:STR:="extern ";
if ~void(arg.tp) then extern:=extern.append(mang(arg.tp)," ");-- AM_EXT_CALL_EXPR::tp BOOL::not STR::append CGEN::mang AM_EXT_CALL_EXPR::tp
else extern:=extern.append("void ");-- STR::append
end;
extern:=extern.append(arg.nm.str,"("); -- STR::append AM_EXT_CALL_EXPR::nm IDENT::str
res::=arg.nm.str.append("(");-- AM_EXT_CALL_EXPR::nm IDENT::str STR::append
i:INT:=1; -- self is not passed to external routines
loop
until!(i>=arg_list.asize);-- INT::is_lt ARRAY{1}::asize BOOL::not
sa ::= arg.fun.args[i-1];-- AM_EXT_CALL_EXPR::fun SIG::args ARRAY{1}::aget INT::minus
tp::=sa.tp;-- ARG::tp
if tp.kind=TP_KIND::ref_tp then-- INT::is_eq TP_KIND::ref_tp
arr:TP_CLASS:=tp.impl.arr;-- IMPL::arr
if ~void(arr) then-- BOOL::not
-- AREF{FOO} passed to external routines really
-- passes a pointer to the array portion.
local::=dec_local_comment(tp,"Local for ext arr arg");-- CGEN::dec_local_comment
ndefer(local.append(" = ",cast(tp, arg[i].expr.tp, arg_list[i],false),";"));-- CGEN::ndefer STR::append CGEN::cast AM_EXT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget
extern:=extern.append(mang(arr.params[0])," []");-- STR::append CGEN::mang TP_CLASS::params ARRAY{1}::aget
res:=res.append("((",local,"==NULL)?NULL:",local,"->arr_part)");-- STR::append
else
extern:=extern.append(arg_type_str(sa));-- STR::append CGEN::arg_type_str
res:=res.append(cast(tp,arg[i].expr.tp,arg_list[i],false));-- STR::append CGEN::cast AM_EXT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget
end;
else
extern:=extern.append(arg_type_str(sa));-- STR::append CGEN::arg_type_str
res:=res.append(cast(tp,arg[i].expr.tp,arg_list[i],false));-- STR::append CGEN::cast AM_EXT_CALL_EXPR::aget AM_CALL_ARG::expr ARRAY{1}::aget
end;
i:=i+1;-- INT::plus
if i<arg_list.asize then-- INT::is_lt ARRAY{1}::asize
extern:=extern.append(", ");-- STR::append
res:=res.append(", ");-- STR::append
end;
end;
extern:=extern.append(");"+eol);-- STR::append CGEN::eol
-- do not emit prototypes for features in runtime. They should
-- be in the system header files.
if ~arg.ext_tp.is_builtin then-- AM_EXT_CALL_EXPR::ext_tp BOOL::not
code_c.uses_extern(extern);-- CGEN::code_c CODE_FILE::uses_extern
end;
return res.append(")");-- STR::append
end;
private emit_am_global_expr(arg:AM_GLOBAL_EXPR):STR is
-- get the global definition stored in the global table,
-- so it will be mangled correctly
orig ::= gen.global_tbl.get(arg.name,arg.class_tp);-- CGEN::gen GENERATE_AM::global_tbl GLOBAL_TBL::get AM_GLOBAL_EXPR::name AM_GLOBAL_EXPR::class_tp
code_c.uses_global(orig);-- CGEN::code_c CODE_FILE::uses_global
return mang(orig);-- CGEN::mang
end;
private emit_am_array_expr(arg:AM_ARRAY_EXPR):STR is
t:$TP:=arg.tp_at;-- AM_ARRAY_EXPR::tp_at
t2:$TP:=am_ob_def_for_tp(t).arr;-- CGEN::am_ob_def_for_tp AM_OB_DEF::arr
res::=dec_local_comment(t,"local for array creation expression");-- CGEN::dec_local_comment
ndefer(res.append(" = ",array_allocate(t,arg.asize.str),";"));-- CGEN::ndefer STR::append CGEN::array_allocate AM_ARRAY_EXPR::asize INT::str
ndefer(res.append("->asize = ",arg.asize.str,";"));-- CGEN::ndefer STR::append AM_ARRAY_EXPR::asize INT::str
loop i::=arg.ind!;-- AM_ARRAY_EXPR::ind!
rhs::=cast(t2,arg[i].tp,emit_expr(arg[i]),false);-- CGEN::cast AM_ARRAY_EXPR::aget CGEN::emit_expr AM_ARRAY_EXPR::aget
ndefer(res.append("->arr_part[",i.str,"] = ",rhs,";"));-- CGEN::ndefer STR::append INT::str
end;
return res;
end;
private emit_am_is_void_expr(arg:AM_IS_VOID_EXPR):STR
pre ~void(arg.arg) is-- AM_IS_VOID_EXPR::arg BOOL::not
arg_tp:$TP:=arg.arg.tp;-- AM_IS_VOID_EXPR::arg
assert ~void(arg_tp);-- BOOL::not
if arg_tp.is_immutable then
return value_void(arg_tp,emit_expr(arg.arg));-- CGEN::value_void CGEN::emit_expr AM_IS_VOID_EXPR::arg
else
if prog.distributed then-- CGEN::prog PROG::distributed
return "FVOID(".append(emit_expr(arg.arg),")");-- STR::append CGEN::emit_expr AM_IS_VOID_EXPR::arg
else
return "(".append(emit_expr(arg.arg),"==",-- STR::append CGEN::emit_expr AM_IS_VOID_EXPR::arg
default_init(arg_tp),")");-- CGEN::default_init
end;
end;
end;
private emit_am_stmt_expr(arg:AM_STMT_EXPR):STR is
if ~void(arg.stmts) then emit_code(arg.stmts); end;-- AM_STMT_EXPR::stmts BOOL::not CGEN::emit_code AM_STMT_EXPR::stmts
if ~void(arg.expr) then return emit_expr(arg.expr);-- AM_STMT_EXPR::expr BOOL::not CGEN::emit_expr AM_STMT_EXPR::expr
else return void;
end;
end;
private emit_am_except_expr(arg:AM_EXCEPT_EXPR):STR is
return cast(arg.tp,TP_BUILTIN::dollar_ob,"EXCEPTION",false);-- CGEN::cast AM_EXCEPT_EXPR::tp TP_BUILTIN::dollar_ob
end;
-- here comes stuff for bnd_routines and for bnd_iters
private emit_am_bnd_create_expr(arg:AM_BND_CREATE_EXPR):STR is
dummy:FLIST{STR};
if arg.fun.is_iter then -- AM_BND_CREATE_EXPR::fun SIG::is_iter
return emit_am_bnd_iter_create_expr(arg); -- (arg,true,out dummy);-- CGEN::emit_am_bnd_iter_create_expr
else
return emit_am_bnd_rout_create_expr(arg,true,out dummy);-- CGEN::emit_am_bnd_rout_create_expr
end;
end;
private emit_am_bnd_rout_create_expr(arg:AM_BND_CREATE_EXPR,
casting:BOOL,
out argstr:FLIST{STR}):STR is
argstr:=void;
bnd_rout_creates:=bnd_rout_creates.push(arg);-- CGEN::bnd_rout_creates CGEN::bnd_rout_creates FLIST{1}::push
code_c.uses_bnd_rout_create(arg);-- CGEN::code_c CODE_FILE::uses_bnd_rout_create
code_c.uses_layout(#BOUND_OBJECT_LAYOUT(arg));-- CGEN::code_c CODE_FILE::uses_layout BOUND_OBJECT_LAYOUT::create
res::=mangler.genlocal(current_sig);-- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(arg)+"_ob "+res+';';-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
if zones then-- CGEN::zones
ndefer(res+" = ("+mang(arg)+"_ob) zalloc(sizeof(struct "-- CGEN::ndefer STR::plus STR::plus CGEN::mang
+mang(arg)+"_ob_struct));");-- STR::plus STR::plus CGEN::mang STR::plus
else
ndefer(res+" = ("+mang(arg)+"_ob) GC_malloc(sizeof(struct "-- CGEN::ndefer STR::plus STR::plus CGEN::mang
+mang(arg)+"_ob_struct));");-- STR::plus STR::plus CGEN::mang STR::plus
end;
ndefer(res+"->header.tag = "+tag_for(arg.tp)+';');-- CGEN::ndefer STR::plus STR::plus CGEN::tag_for AM_BND_CREATE_EXPR::tp STR::plus
ndefer(res+"->funcptr = "+mang(arg)+';');-- CGEN::ndefer STR::plus STR::plus CGEN::mang STR::plus
loop
i::=arg.ind!;-- AM_BND_CREATE_EXPR::ind!
entry:STR;
idx::=arg.bnd_args[i];-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::aget
if idx=0 then-- INT::is_eq
if ~arg.fun.tp.is_external then-- AM_BND_CREATE_EXPR::fun SIG::tp BOOL::not
entry:=cast(arg.fun.tp,arg[i].expr.tp,emit_expr(arg[i].expr),false);-- CGEN::cast AM_BND_CREATE_EXPR::fun SIG::tp AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr CGEN::emit_expr AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
ndefer(res+"->bound_arg"+i+" = "+entry+';');-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
end;
else
-- outmode is only possible for remote procedure calls generated
-- for pSather, but never for BND ROUT created by user code
a::=arg.fun.args[idx-1];-- AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::aget INT::minus
if a.mode/=MODES::out_mode then-- ARG::mode MODES::out_mode BOOL::not
ex::=emit_expr(arg[i].expr);-- CGEN::emit_expr AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
if a.mode=MODES::inout_mode then-- ARG::mode MODES::inout_mode
argstr:=argstr.push(ex);-- FLIST{1}::push
end;
entry:=cast(a.tp,arg[i].expr.tp,ex,false);-- CGEN::cast ARG::tp AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
if arg.is_remote then-- AM_BND_CREATE_EXPR::is_remote
if a.tp.is_immutable then-- ARG::tp
ndefer(res+"->bound_arg"+i+" = "+entry+';');-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
if ~a.tp.is_atomic then-- ARG::tp BOOL::not
ndefer("SENDOB("+tag_for(a.tp)+-- CGEN::ndefer STR::plus CGEN::tag_for ARG::tp
",&"+res+"->bound_arg"+i+-- STR::plus STR::plus STR::plus STR::plus
","+arg.clst+");");-- STR::plus STR::plus AM_BND_CREATE_EXPR::clst STR::plus
end;
else
ndefer(res+"->bound_arg"+i+" = SENDFOB("+entry+","+arg.clst+");");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus AM_BND_CREATE_EXPR::clst STR::plus
end;
else
ndefer(res+"->bound_arg"+i+" = "+entry+';');-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
end;
end;
end;
end;
make_sure_emitted(arg.fun);-- CGEN::make_sure_emitted AM_BND_CREATE_EXPR::fun
if casting then
return "("+mang(arg.tp)+") "+res;-- STR::plus CGEN::mang AM_BND_CREATE_EXPR::tp STR::plus STR::plus
else
return res;
end;
end;
private get_inout_args_back(arg:AM_BND_CREATE_EXPR,arglist:FLIST{STR},local:STR,where:STR) is
loop
i::=arg.ind!;-- AM_BND_CREATE_EXPR::ind!
entry:STR;
idx::=arg.bnd_args[i];-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::aget
if idx/=0 then -- self is never of type out-- INT::is_eq BOOL::not
-- outmode is only possible for remote procedure calls generated
-- for pSather, but never for BND ROUT created by user code
a::=arg.fun.args[idx-1];-- AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::aget INT::minus
ex::="";
if a.mode/=MODES::in_mode then-- ARG::mode MODES::in_mode BOOL::not
if a.mode=MODES::out_mode then-- ARG::mode MODES::out_mode
ex:=emit_expr(arg[i].expr);-- CGEN::emit_expr AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
else
ex:=arglist.elt!;-- FLIST{1}::elt!
end;
b::=local+"->bound_arg"+i;-- STR::plus STR::plus
entry:=cast(arg[i].expr.tp,a.tp,b,false);-- CGEN::cast AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr ARG::tp
if arg[i].expr.tp.is_immutable then-- AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
ndefer(ex+" = "+entry+";");-- CGEN::ndefer STR::plus STR::plus STR::plus
if ~arg[i].expr.tp.is_atomic then-- AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr BOOL::not
ndefer("RECVOB("+tag_for(arg[i].expr.tp)+",&"+ex+","+where+");");-- CGEN::ndefer STR::plus CGEN::tag_for AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr STR::plus STR::plus STR::plus STR::plus STR::plus
end;
else
ndefer(ex+" = RECVFOB("+entry+","+where+");");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
end;
end;
end;
end;
end;
make_sure_emitted(s:SIG) is
-- Some routines are skipped because they are inlined.
-- If they need to be generated anyway, e.g. for dispatching,
-- then they get put in 'leftovers'.
ard::=not_emitted.get(s);-- CGEN::not_emitted FMAP{2}::get
if ~void(ard) then-- BOOL::not
leftovers:=leftovers.insert(ard);-- CGEN::leftovers CGEN::leftovers FSET{1}::insert
not_emitted:=not_emitted.delete(s);-- CGEN::not_emitted CGEN::not_emitted FMAP{2}::delete
end;
end;
private emit_am_bnd_rout_call_expr(arg:AM_BND_ROUT_CALL_EXPR):STR is
tp::=arg.br_tp;-- AM_BND_ROUT_CALL_EXPR::br_tp
br::=dec_local(tp);-- CGEN::dec_local
ndefer(br.append(" = ",cast(tp,arg.br.tp,emit_expr(arg.br),false),";"));-- CGEN::ndefer STR::append CGEN::cast AM_BND_ROUT_CALL_EXPR::br CGEN::emit_expr AM_BND_ROUT_CALL_EXPR::br
-- The cast is necessary if it's in a typecase.
res::="(*(".append(br,"->funcptr))(",br);-- STR::append
arg_list::=emit_and_cast_args(arg);-- CGEN::emit_and_cast_args
arg_strs:STR;
loop
i::=0.upto!(arg_list.size-1);-- INT::upto! ARRAY{1}::size INT::minus
arg_strs := arg_strs + "," + arg_list[i];-- STR::plus STR::plus ARRAY{1}::aget
end;
if ~void(arg_strs) then-- BOOL::not
res := res.append(arg_strs);-- STR::append
end;
if func_tables then-- CGEN::func_tables
res:=res.append(",&FF");-- STR::append
end;
res := res.append(")");-- STR::append
if need_caller_copy_out(arg) then-- CGEN::need_caller_copy_out
if ~void(arg.tp) then-- AM_BND_ROUT_CALL_EXPR::tp BOOL::not
func_res ::= dec_local(arg.tp);-- CGEN::dec_local AM_BND_ROUT_CALL_EXPR::tp
ndefer( func_res+" = " + res + ';');-- CGEN::ndefer STR::plus STR::plus STR::plus
caller_copy_out(arg, arg_list);-- CGEN::caller_copy_out
return func_res;
else
-- no result is needed
ndefer(res + ';');-- CGEN::ndefer STR::plus
caller_copy_out(arg, arg_list);-- CGEN::caller_copy_out
return void;
end;
else
return res;
end;
end;
private emit_am_bnd_iter_create_expr(arg:AM_BND_CREATE_EXPR):STR is
-- momentarily not implemented
--if arg.fun.is_builtin
--then barf("Binding of builtin iters is currently not possible.\n"); end;
bnd_iter_creates:=bnd_iter_creates.push(arg);-- CGEN::bnd_iter_creates CGEN::bnd_iter_creates FLIST{1}::push
--if arg.fun.is_builtin then
-- barf("Binding of builtin iterators is not yet supported."); end;
code_c.uses_bnd_iter_create(arg);-- CGEN::code_c CODE_FILE::uses_bnd_iter_create
code_c.uses_sig(arg.fun);-- CGEN::code_c CODE_FILE::uses_sig AM_BND_CREATE_EXPR::fun
code_c.uses_iter(arg.fun);-- CGEN::code_c CODE_FILE::uses_iter AM_BND_CREATE_EXPR::fun
if arg.fun.tp.is_abstract then -- AM_BND_CREATE_EXPR::fun SIG::tp
code_c.uses_layout(#ABSTRACT_FRAME_LAYOUT(arg.fun,prog));-- CGEN::code_c CODE_FILE::uses_layout ABSTRACT_FRAME_LAYOUT::create AM_BND_CREATE_EXPR::fun CGEN::prog
else
a:AM_ROUT_DEF:=code_c.iter_sigs.get(arg.fun);-- CGEN::code_c CODE_FILE::iter_sigs FMAP{2}::get AM_BND_CREATE_EXPR::fun
if void(a) then
-- iter could have been inlined so check our table
a:=itersig_map.get(arg.fun);-- CGEN::itersig_map FMAP{2}::get AM_BND_CREATE_EXPR::fun
if void(a) then -- this sould never happen !
barf("Iter signature not found in : emit_am_bnd_iter_create."); -- CGEN::barf
end;
end;
-- table that maps sigs of iters to their am_rout_defs for later use
-- in generate_bnd_iter_stubs,
itersig_map := itersig_map.insert(arg.fun,a);-- CGEN::itersig_map CGEN::itersig_map FMAP{2}::insert AM_BND_CREATE_EXPR::fun
code_c.uses_layout(#FRAME_LAYOUT(a,prog)); -- CGEN::code_c CODE_FILE::uses_layout FRAME_LAYOUT::create CGEN::prog
end;
-- builtin iters are not stored in iter_sig !!
code_c.uses_layout(#BOUND_ITER_FRAME_LAYOUT(arg,prog));-- CGEN::code_c CODE_FILE::uses_layout BOUND_ITER_FRAME_LAYOUT::create CGEN::prog
l_res ::= mangler.genlocal(current_sig); -- CGEN::mangler MANGLE::genlocal CGEN::current_sig
code_c+eol+' '+mang(arg)+"_iter_ob "+l_res+';';-- CGEN::code_c CGEN::eol CODE_FILE::plus CODE_FILE::plus CGEN::mang CODE_FILE::plus CODE_FILE::plus CODE_FILE::plus
in; ndefer(" ");-- CGEN::in CGEN::ndefer
ndefer(eol+l_res+" = OB_ALLOC(" + mang(arg) + "_iter_ob);"); -- CGEN::eol STR::plus STR::plus STR::plus CGEN::mang STR::plus
ndefer(l_res+"->header.tag = "+tag_for(arg.tp)+';');-- CGEN::ndefer STR::plus STR::plus CGEN::tag_for AM_BND_CREATE_EXPR::tp STR::plus
ndefer(l_res+"->size = sizeof(struct " + mang(arg) + "_iter_ob_struct);"); -- CGEN::ndefer STR::plus STR::plus CGEN::mang STR::plus
ndefer(l_res + "->state = 0;" + " /* initialize state */");-- CGEN::ndefer STR::plus STR::plus
ndefer(l_res + "->call = "); -- CGEN::ndefer STR::plus
if ~void(arg.fun.ret) then -- AM_BND_CREATE_EXPR::fun SIG::ret BOOL::not
defer("("+mang(arg.fun.ret, void) + " (*) (");-- CGEN::defer STR::plus CGEN::mang AM_BND_CREATE_EXPR::fun SIG::ret STR::plus
else
defer("( void (*) ("); -- CGEN::defer
end;
defer(mang(arg) + "_iter_ob");-- CGEN::defer CGEN::mang STR::plus
if func_tables then-- CGEN::func_tables
defer(", struct _func_frame *"); end;-- CGEN::defer
defer("))"+mang(arg)+"_call_function;"); -- CGEN::defer STR::plus CGEN::mang STR::plus
-- set bound arguments
comment("set bound arguments");-- CGEN::comment
loop
i::=arg.ind!;-- AM_BND_CREATE_EXPR::ind!
entry:STR;
idx::=arg.bnd_args[i];-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::aget
if idx=0 then-- INT::is_eq
entry:=cast(arg.fun.tp,arg[i].expr.tp,emit_expr(arg[i].expr),false);-- CGEN::cast AM_BND_CREATE_EXPR::fun SIG::tp AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr CGEN::emit_expr AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
ndefer(l_res+"->bound_arg"+i+" = "+entry+';');-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
else
entry:=cast(arg.fun.args[idx-1].tp,arg[i].expr.tp,-- CGEN::cast AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::aget INT::minus ARG::tp AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
emit_expr(arg[i].expr),false);-- CGEN::emit_expr AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
ndefer(l_res+"->bound_arg"+i+" = "+entry+';')-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
end;
end;
code_c + " \n";-- CGEN::code_c CODE_FILE::plus
make_sure_emitted(arg.fun);-- CGEN::make_sure_emitted AM_BND_CREATE_EXPR::fun
return "("+mang(arg.tp)+") "+l_res;-- STR::plus CGEN::mang AM_BND_CREATE_EXPR::tp STR::plus STR::plus
end;
private emit_am_bnd_iter_call_expr(arg:AM_BND_ITER_CALL_EXPR):STR is
tp::=arg.bi_tp; -- AM_BND_ITER_CALL_EXPR::bi_tp
bi::=dec_local(tp);-- CGEN::dec_local
s1,res:STR;
if ~void(arg.tp) then-- AM_BND_ITER_CALL_EXPR::tp BOOL::not
s1:=dec_local_comment(arg.tp,-- CGEN::dec_local_comment AM_BND_ITER_CALL_EXPR::tp
"Holds result of call to "+arg.bi_tp.str);-- STR::plus AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::str
end;
-- treatment of builtin iters comes here
biter_name ::= mang(arg,current_sig);-- CGEN::mang CGEN::current_sig
if void(biter_name) then barf("Unrecognized Sather bound iter name: "
+emit_expr(arg.bi));-- CGEN::barf STR::plus CGEN::emit_expr AM_BND_ITER_CALL_EXPR::bi
end;
ndefer("if (".append(biter_name,"->state == 0) {"));-- CGEN::ndefer STR::append
in;-- CGEN::in
-- initialization : treatment of once arg
emit_bnd_iter_initialization(arg);-- CGEN::emit_bnd_iter_initialization
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
-- treatment of hot args, loop over unbnd args and pick out hot ones
-- hot might be void, if there are non hot !
if ~void(arg.bi_tp.hot) then -- AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::hot BOOL::not
loop
i::=arg.ind!;-- AM_BND_ITER_CALL_EXPR::ind!
if arg.bi_tp.hot[i] then-- AM_BND_ITER_CALL_EXPR::bi_tp TP_ITER::hot ARRAY{1}::aget
comment("hot argument");-- CGEN::comment
-- check whether indicies are right aj, arg[] includes self !!
arg_str ::= emit_call_arg(arg[i], tp.args[i], false, false);-- CGEN::emit_call_arg AM_BND_ITER_CALL_EXPR::aget TP_ITER::args ARRAY{1}::aget
if tp.args[i].tp.is_immutable -- TP_ITER::args ARRAY{1}::aget ARG::tp
and SYS::ob_eq(arg[i].mode, MODES::out_mode) -- SYS::ob_eq AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::mode MODES::out_mode
and arg[i].expr.tp.is_abstract then-- AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
ndefer(biter_name.append("->hotarg",i.str," = ",arg_str-- CGEN::ndefer STR::append INT::str
,";"));
else
ndefer(biter_name.append("->hotarg",i.str," = ",-- CGEN::ndefer STR::append INT::str
cast_arg(tp.args[i].-- CGEN::cast_arg TP_ITER::args ARRAY{1}::aget
tp,arg[i].expr.-- ARG::tp AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
tp,
arg_str,
false,
arg[i].mode),-- AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::mode
";"));
end; -- ends if is_immutable
end; -- ends if hot
end; -- ends loop
end; -- ends ~void(arg.bi_tp.hot) then
pro::="";
if func_tables then -- CGEN::func_tables
pro:=",&FF";
end;
-- potentially handling of abstract stuff/psather stuff
-- the actual call
if ~void(arg.tp) then-- AM_BND_ITER_CALL_EXPR::tp BOOL::not
ndefer(s1+" = (*(".append(biter_name, "->call))((void *) " +-- CGEN::ndefer STR::plus STR::append
biter_name) + pro +");");-- STR::plus STR::plus STR::plus
res:=s1;
else
ndefer("(*(".append(biter_name, "->call))((void *) " +-- CGEN::ndefer STR::append
biter_name) + pro +");");-- STR::plus STR::plus STR::plus
res:="/* No return value from iter call */";
end;
-- termination test
ndefer("if (".append(biter_name,"->state == -1) {"));-- CGEN::ndefer STR::append
in;-- CGEN::in
ndefer("goto ".append(current_loop,";"));-- CGEN::ndefer STR::append CGEN::current_loop
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
pop_exceptions(ex_nesting-current_loop_ex_nesting);-- CGEN::ex_nesting CGEN::current_loop_ex_nesting
return res;
end;
-- pSather nodes
private emit_am_here_expr(arg:AM_HERE_EXPR):STR is
if ~prog.distributed then return "0"; end;-- CGEN::prog PROG::distributed BOOL::not
return("HERE");
end;
private emit_am_any_expr(arg:AM_ANY_EXPR):STR is
return "ANY";
end;
private emit_am_cluster_expr(arg:AM_CLUSTER_EXPR):STR is
if ~prog.distributed then return "1"; end;-- CGEN::prog PROG::distributed BOOL::not
return("CLUSTERS");
end;
private emit_am_cluster_size_expr(arg:AM_CLUSTER_SIZE_EXPR):STR is
return("MY_CLUSTER_SIZE");
end;
private emit_am_far_expr(arg:AM_FAR_EXPR):STR is
if arg.arg.tp.is_immutable then return "0"; end;-- AM_FAR_EXPR::arg
if ~prog.distributed then return "0"; end;-- CGEN::prog PROG::distributed BOOL::not
return "PS_FAR("+emit_expr(arg.arg)+")";-- STR::plus CGEN::emit_expr AM_FAR_EXPR::arg STR::plus
end;
private emit_am_where_expr(arg:AM_WHERE_EXPR):STR is
if ~prog.distributed then return "0"; end;-- CGEN::prog PROG::distributed BOOL::not
if arg.arg.tp.is_immutable then return "HERE"; end;-- AM_WHERE_EXPR::arg
return "PS_WHERE("+emit_expr(arg.arg)+")";-- STR::plus CGEN::emit_expr AM_WHERE_EXPR::arg STR::plus
end;
private emit_am_near_expr(arg:AM_NEAR_EXPR):STR is
if arg.arg.tp.is_immutable then return "0"; end;-- AM_NEAR_EXPR::arg
if ~prog.distributed then return "1"; end;-- CGEN::prog PROG::distributed BOOL::not
return "PS_NEAR("+emit_expr(arg.arg)+")";-- STR::plus CGEN::emit_expr AM_NEAR_EXPR::arg STR::plus
end;
private emit_am_with_near_stmt(arg:AM_WITH_NEAR_STMT) is
s:STR;
loop
a::=arg.objects.elt!;-- AM_WITH_NEAR_STMT::objects ARRAY{1}::elt!
t:STR;
if a.tp.is_immutable then
t:="0";
else
t:="PS_NEAR_OR_VOID("+emit_expr(arg.objects.elt!)+")";-- STR::plus CGEN::emit_expr AM_WITH_NEAR_STMT::objects ARRAY{1}::elt! STR::plus
end;
s:=s+"&&".separate!(t);-- STR::plus STR::separate!
end;
ndefer("if("+s+") {");-- CGEN::ndefer STR::plus STR::plus
in;-- CGEN::in
emit_code(arg.near_part);-- CGEN::emit_code AM_WITH_NEAR_STMT::near_part
move_out;-- CGEN::move_out
ndefer("} else {");-- CGEN::ndefer
in;-- CGEN::in
emit_code(arg.else_part);-- CGEN::emit_code AM_WITH_NEAR_STMT::else_part
move_out;-- CGEN::move_out
ndefer("}");-- CGEN::ndefer
end;
private emit_am_at_expr(arg:AM_AT_EXPR):STR is
if ~prog.distributed then return emit_expr(arg.e); end;-- CGEN::prog PROG::distributed BOOL::not CGEN::emit_expr AM_AT_EXPR::e
e::=arg.e;-- AM_AT_EXPR::e
typecase e
when AM_ROUT_CALL_EXPR then
loc::=emit_expr(arg.at);-- CGEN::emit_expr AM_AT_EXPR::at
res:STR;
bnd::=#AM_BND_CREATE_EXPR(e.size,e.source);-- AM_BND_CREATE_EXPR::create AM_ROUT_CALL_EXPR::size AM_ROUT_CALL_EXPR::source
loop bnd.set!(e.elt!); end;-- AM_BND_CREATE_EXPR::set! AM_ROUT_CALL_EXPR::elt!
bnd.is_remote:=true;-- AM_BND_CREATE_EXPR::is_remote
bnd.clst:=loc;-- AM_BND_CREATE_EXPR::clst
bnd.fun:=e.fun;-- AM_BND_CREATE_EXPR::fun AM_ROUT_CALL_EXPR::fun
bnd.bnd_args:=#(e.size);-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::create AM_ROUT_CALL_EXPR::size
loop bnd.bnd_args.set!(0.up!); end;-- AM_BND_CREATE_EXPR::bnd_args ARRAY{1}::set! INT::up!
tbnd::=#TP_ROUT(void,e.fun.ret,prog);-- TP_ROUT::create AM_ROUT_CALL_EXPR::fun SIG::ret CGEN::prog
bnd.tp_at:=tbnd;-- AM_BND_CREATE_EXPR::tp_at
al:FLIST{STR};
rt::=emit_am_bnd_rout_create_expr(bnd,false,out al);-- CGEN::emit_am_bnd_rout_create_expr
ndefer(rt+"->local=SENDFOB("+rt+","+loc+");");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus STR::plus
if ~void(arg.e.tp) then-- AM_AT_EXPR::e BOOL::not
res:=dec_local(arg.e.tp);-- CGEN::dec_local AM_AT_EXPR::e
ndefer("REMOTE_EXEC("+loc+","+rt+");");-- CGEN::ndefer STR::plus STR::plus STR::plus STR::plus
if e.tp.is_immutable then-- AM_ROUT_CALL_EXPR::tp
if ~e.tp.is_atomic then-- AM_ROUT_CALL_EXPR::tp BOOL::not
ndefer("RECVOB("+tag_for(e.tp)+",&"+rt+"->ret_arg,"+loc+");");-- CGEN::ndefer STR::plus CGEN::tag_for AM_ROUT_CALL_EXPR::tp STR::plus STR::plus STR::plus STR::plus STR::plus
end;
res:=rt+"->ret_arg";-- STR::plus
else
res:="RECVFOB("+rt+"->ret_arg,"+loc+")";-- STR::plus STR::plus STR::plus STR::plus
end;
else
res:="REMOTE_EXEC("+loc+","+rt+");";-- STR::plus STR::plus STR::plus STR::plus
end;
get_inout_args_back(bnd,al,rt,loc);-- CGEN::get_inout_args_back
return res;
else
warning("@cluster works currently only for routine calls, not for "+SYS::str_for_tp(SYS::tp(e))+", ignoring @");-- CGEN::warning STR::plus SYS::str_for_tp SYS::tp STR::plus
ndefer("/* the following call should be made at some other cluster */");-- CGEN::ndefer
return emit_expr(e);-- CGEN::emit_expr
end;
end;
private emit_am_arr_const(arg:AM_ARR_CONST):STR is
barf("array constants not implemented yet"); return "";
end;
private emit_am_inti_const(arg:AM_INTI_CONST):STR is
barf("INTI constants not implemented yet"); return "";
end;
private emit_am_flti_const(arg:AM_FLTI_CONST):STR is
barf("FLTI constants not implemented yet"); return "";
end;
private emit_am_fltx_const(arg:AM_FLTX_CONST):STR is
barf("FLTX constants not implemented yet"); return "";
end;
private emit_am_fltdx_const(arg:AM_FLTDX_CONST):STR is
barf("FLTDX constants not implemented yet"); return "";
end;
private value_compare(tp:$TP,e1,e2:STR):STR pre tp.is_immutable is
-- expression for comparing contents of two value types
if tp.is_builtin then return "(".append(mang(tp),"_IS_EQ(",e1,",",e2,"))"); end;-- STR::append CGEN::mang
aod:AM_OB_DEF:=am_ob_def_for_tp(tp);-- CGEN::am_ob_def_for_tp
after_first:BOOL:=false;
res::="";
if ~void(aod.at) then-- AM_OB_DEF::at BOOL::not
loop
p::=aod.at.pairs!;-- AM_OB_DEF::at FMAP{2}::pairs!
key:STR:=mang(p.t1,tp);-- CGEN::mang TUP{2}::t1
if after_first then res:=res+"&&"; end;-- STR::plus
if p.t2.is_immutable then-- TUP{2}::t2
res:=res+value_compare(p.t2,e1+'.'+key,e2+'.'+key);-- STR::plus CGEN::value_compare TUP{2}::t2 STR::plus STR::plus STR::plus STR::plus
else
--res:=res+'('+e1+'.'+key+"=="+e2+'.'+key+')';
res:=res+"SYSOBEQ("+e1+'.'+key+','+e2+'.'+key+')';-- STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
end;
after_first:=true;
end;
end;
if ~void(aod.arr) then-- AM_OB_DEF::arr BOOL::not
loop
i::=0.for!(aod.asize);-- INT::for! AM_OB_DEF::asize
if after_first then res:=res+"&&"; end;-- STR::plus
if aod.arr.is_immutable then-- AM_OB_DEF::arr
res:=res+value_compare(aod.arr,e1+".arr_part["+i+"]",e2+".arr_part["+i+"]");-- STR::plus CGEN::value_compare AM_OB_DEF::arr STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
else
res:=res+"("+e1+".arr_part["+i+"]=="+e2+".arr_part["+i+"])";-- STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus
end;
after_first:=true;
end;
end;
return res;
end;
private value_void(tp:$TP,e:STR):STR pre tp.is_immutable is
-- expression for comparing value types to void (all zero elements)
if tp.is_immutable and tp.is_builtin then return mang(tp)+"_IS_VOID("+e+")"; end;-- CGEN::mang STR::plus STR::plus STR::plus
aod:AM_OB_DEF:=am_ob_def_for_tp(tp);-- CGEN::am_ob_def_for_tp
after_first:BOOL:=false;
res::="";
code_c.uses_tp(tp);-- CGEN::code_c CODE_FILE::uses_tp
if ~void(aod.at) then-- AM_OB_DEF::at BOOL::not
loop
p::=aod.at.pairs!;-- AM_OB_DEF::at FMAP{2}::pairs!
key:STR:=mang(p.t1,tp);-- CGEN::mang TUP{2}::t1
if after_first then res:=res+"&&"; end;-- STR::plus
if p.t2.is_immutable then-- TUP{2}::t2
res:=res+value_void(p.t2,e+'.'+key);-- STR::plus CGEN::value_void TUP{2}::t2 STR::plus STR::plus
else
code_c.uses_tp(p.t2);-- CGEN::code_c CODE_FILE::uses_tp TUP{2}::t2
res:=res+'('+e+'.'+key+"==("+mang(p.t2)+")0)";-- STR::plus STR::plus STR::plus STR::plus STR::plus STR::plus CGEN::mang TUP{2}::t2 STR::plus
end;
after_first:=true;
end;
end;
if ~void(aod.arr) then-- AM_OB_DEF::arr BOOL::not
code_c.uses_tp(aod.arr);-- CGEN::code_c CODE_FILE::uses_tp AM_OB_DEF::arr
loop i::=0.for!(aod.asize);-- INT::for! AM_OB_DEF::asize
if after_first then res:=res+"&&"; end;-- STR::plus
if aod.arr.is_immutable then-- AM_OB_DEF::arr
res:=res+value_void(aod.arr,e+".arr_part["+i+"]");-- STR::plus CGEN::value_void AM_OB_DEF::arr STR::plus STR::plus STR::plus
else
res:=res+'('+e+".arr_part["+i-- STR::plus STR::plus STR::plus STR::plus
+"]==("+mang(aod.arr)+")0)";-- STR::plus STR::plus CGEN::mang AM_OB_DEF::arr STR::plus
end;
after_first:=true;
end;
end;
return res;
end;
private make_tag_table is
-- Assign numbers to every type which needs a tag. This
-- needs to be deterministic to avoid recompiling everything
-- when tag numbers change. So we sort them alphabetically.
a::=#ARRAY{$TP}(needs_tag.size);-- ARRAY{1}::create CGEN::needs_tag FSET{1}::size
loop
a.set!(needs_tag.elt!);-- ARRAY{1}::set! CGEN::needs_tag FSET{1}::elt!
end;
a.sort;-- ARRAY{1}::sort
pos:INT:=1;
neg:INT:= -1;
loop
tp::=a.elt!;-- ARRAY{1}::elt!
if tp.is_immutable then
tags:=tags.insert(tp,neg);-- CGEN::tags CGEN::tags FMAP{2}::insert
neg:=neg-1;-- INT::minus
else
tags:=tags.insert(tp,pos);-- CGEN::tags CGEN::tags FMAP{2}::insert
pos:=pos+1;-- INT::plus
end;
end;
end;
adjust_tag_table:BOOL is
-- Assign numbers to the types that are in needs_tag but not in
-- the table, that is those added in the leftovers.
-- return true if there were new tags, false otherwise
new_ntg::=needs_tag.copy;-- CGEN::needs_tag FSET{1}::copy
loop new_ntg:=new_ntg.delete(tags.keys!) end;-- FSET{1}::delete CGEN::tags FMAP{2}::keys!
if new_ntg.size=0 then return false; end;-- FSET{1}::size INT::is_eq
a::=#ARRAY{$TP}(new_ntg.size);-- ARRAY{1}::create FSET{1}::size
loop
a.set!(new_ntg.elt!);-- ARRAY{1}::set! FSET{1}::elt!
end;
a.sort;-- ARRAY{1}::sort
pos:INT:=0;
neg:INT:=0;
loop
n::=tags.targets!;-- CGEN::tags FMAP{2}::targets!
if n>pos then pos:=n end;-- INT::is_lt
if n<neg then neg:=n end;-- INT::is_lt
end;
pos:=pos+1;-- INT::plus
neg:=neg-1;-- INT::minus
loop
tp::=a.elt!;-- ARRAY{1}::elt!
if tp.is_immutable then
tags:=tags.insert(tp,neg);-- CGEN::tags CGEN::tags FMAP{2}::insert
neg:=neg-1;-- INT::minus
else
tags:=tags.insert(tp,pos);-- CGEN::tags CGEN::tags FMAP{2}::insert
pos:=pos+1;-- INT::plus
end;
end;
return true;
end;
tag_for(tp:$TP):STR is
-- Expression corresponding to a particular type. If not known,
-- make a new one.
needs_tag:=needs_tag.insert(tp); -- make sure gets entered into table-- CGEN::needs_tag CGEN::needs_tag FSET{1}::insert
res::=mang(tp).append("_tag");-- CGEN::mang STR::append
forbid(res);-- CGEN::forbid
return res;
end;
end; -- BE
-- vim:sw=3:nosmartindent