| 1 | //! Lower a single program unit (program / module / subprogram) to IR. |
| 2 | //! |
| 3 | //! Extracted from `core.rs` in Sprint 11 Stage A. Pure mechanical |
| 4 | //! move — behavior unchanged. The function still consults all of |
| 5 | //! core's lowering helpers, which were widened to `pub(super)` |
| 6 | //! visibility in the same commit. |
| 7 | |
| 8 | use std::collections::{HashMap, HashSet}; |
| 9 | |
| 10 | use crate::ast::decl::TypeSpec; |
| 11 | use crate::ast::unit::*; |
| 12 | use crate::ir::builder::FuncBuilder; |
| 13 | use crate::ir::inst::*; |
| 14 | use crate::ir::types::*; |
| 15 | use crate::sema::symtab::SymbolTable; |
| 16 | |
| 17 | use super::const_scalar::ConstScalar; |
| 18 | use super::core::*; |
| 19 | use super::ctx::{ |
| 20 | AmbiguousUseWarnings, CharKind, HiddenResultAbi, LocalInfo, LowerCtx, ProcScopeGuard, |
| 21 | SmpExtraHostGuard, |
| 22 | }; |
| 23 | use super::helpers::clamp_nonnegative_i64; |
| 24 | |
| 25 | pub(crate) fn lower_unit( |
| 26 | module: &mut Module, |
| 27 | unit: &SpannedUnit, |
| 28 | st: &SymbolTable, |
| 29 | globals: &HashMap<(String, String), ModuleGlobalInfo>, |
| 30 | type_layouts: &crate::sema::type_layout::TypeLayoutRegistry, |
| 31 | // Audit CRITICAL-4: USE imports from the host program unit |
| 32 | // (and its hosts, transitively). Per F2018 §16.2, names |
| 33 | // imported into a host are visible in its contained |
| 34 | // subprograms via host association. Each lower_unit call |
| 35 | // accumulates its own uses on top of host_uses and passes |
| 36 | // the combined list down to any nested subprogram. The |
| 37 | // top-level call from lower_file passes an empty slice. |
| 38 | host_uses: &[crate::ast::decl::SpannedDecl], |
| 39 | host_param_consts: &HashMap<String, ConstScalar>, |
| 40 | // `host_decls`: decls of the immediate enclosing program unit. |
| 41 | // Used by contained subprograms to resolve element type, dims, |
| 42 | // and character-kind for each host-associated variable the |
| 43 | // closure-passing ABI threads in as a hidden pointer param. |
| 44 | host_decls: &[crate::ast::decl::SpannedDecl], |
| 45 | host_link_name: Option<&str>, |
| 46 | host_module: Option<&str>, |
| 47 | alloc_return_funcs: &HashSet<String>, |
| 48 | optional_params: &HashMap<String, Vec<bool>>, |
| 49 | descriptor_params: &HashMap<String, Vec<bool>>, |
| 50 | internal_funcs: &HashMap<String, u32>, |
| 51 | elemental_funcs: &HashSet<String>, |
| 52 | char_len_star_params: &HashMap<String, Vec<bool>>, |
| 53 | // `contained_host_refs`: per-callee ordered list of host-local |
| 54 | // names it reads or writes. Drives both callee signature |
| 55 | // (hidden trailing pointer params) and call-site arg list. |
| 56 | contained_host_refs: &HashMap<String, Vec<String>>, |
| 57 | ambiguous_use_warnings: &AmbiguousUseWarnings, |
| 58 | internal_only: bool, |
| 59 | // Sema scope id of the immediate host program unit (when this unit |
| 60 | // is a contained procedure). Used to disambiguate same-name + |
| 61 | // same-signature contained procedures across hosts. |
| 62 | host_scope_id: Option<crate::sema::symtab::ScopeId>, |
| 63 | ) { |
| 64 | match &unit.node { |
| 65 | ProgramUnit::Program { |
| 66 | name, |
| 67 | decls, |
| 68 | body, |
| 69 | contains, |
| 70 | uses, |
| 71 | .. |
| 72 | } => { |
| 73 | let fname = name.clone().unwrap_or_else(|| "main".into()); |
| 74 | let visible_param_consts = |
| 75 | collect_decl_param_consts_with_host(decls, host_param_consts); |
| 76 | let body_fname = format!("__prog_{}", fname); |
| 77 | let mut func = Function::new(body_fname.clone(), vec![], IrType::Void); |
| 78 | let mut ctx = LowerCtx::new( |
| 79 | st, |
| 80 | globals, |
| 81 | type_layouts, |
| 82 | alloc_return_funcs, |
| 83 | optional_params, |
| 84 | descriptor_params, |
| 85 | internal_funcs, |
| 86 | elemental_funcs, |
| 87 | char_len_star_params, |
| 88 | contained_host_refs, |
| 89 | ambiguous_use_warnings.clone(), |
| 90 | ); |
| 91 | ctx.proc_scope_id = { |
| 92 | let raw_name = name.as_deref(); |
| 93 | st.all_scopes() |
| 94 | .iter() |
| 95 | .enumerate() |
| 96 | .find_map(|(idx, scope)| match (&scope.kind, raw_name) { |
| 97 | (crate::sema::symtab::ScopeKind::Program(scope_name), Some(n)) => { |
| 98 | scope_name.eq_ignore_ascii_case(n).then_some(idx) |
| 99 | } |
| 100 | (crate::sema::symtab::ScopeKind::Program(_), None) => Some(idx), |
| 101 | _ => None, |
| 102 | }) |
| 103 | }; |
| 104 | let mut pending_globals: Vec<PendingGlobal> = Vec::new(); |
| 105 | |
| 106 | let combined_uses: Vec<crate::ast::decl::SpannedDecl> = |
| 107 | host_uses.iter().chain(uses.iter()).cloned().collect(); |
| 108 | let required_import_names = collect_required_import_names(decls, body); |
| 109 | |
| 110 | { |
| 111 | let mut b = FuncBuilder::new(&mut func); |
| 112 | install_common_locals(&mut b, &mut ctx.locals, decls); |
| 113 | install_equivalence_locals(&mut b, &mut ctx.locals, decls, &visible_param_consts, st); |
| 114 | super::alloc::alloc_decls( |
| 115 | &mut b, |
| 116 | &mut ctx.locals, |
| 117 | decls, |
| 118 | &visible_param_consts, |
| 119 | type_layouts, |
| 120 | &mut pending_globals, |
| 121 | &fname, |
| 122 | st, |
| 123 | ); |
| 124 | install_host_param_consts(&mut b, &mut ctx.locals, host_param_consts, st); |
| 125 | install_globals_as_locals( |
| 126 | &mut b, |
| 127 | &mut ctx.locals, |
| 128 | globals, |
| 129 | &combined_uses, |
| 130 | Some(&required_import_names), |
| 131 | host_module, |
| 132 | ctx.st, |
| 133 | &ctx.ambiguous_use_warnings, |
| 134 | ); |
| 135 | ctx.filtered_names = compute_filtered_names(globals, &combined_uses, decls); |
| 136 | check_no_filtered_refs(body, &ctx.filtered_names); |
| 137 | collect_implicit_locals(&mut b, &mut ctx, body, UnitScope::Program(&fname)); |
| 138 | super::init::init_decls(&mut b, &ctx.locals, decls, st, Some(type_layouts)); |
| 139 | collect_label_blocks(&mut b, body, &mut ctx.label_blocks); |
| 140 | let _proc_scope_guard = ProcScopeGuard::enter(ctx.proc_scope_id); |
| 141 | super::stmt::lower_stmts(&mut b, &mut ctx, body); |
| 142 | drop(_proc_scope_guard); |
| 143 | if b.func().block(b.current_block()).terminator.is_none() { |
| 144 | insert_implicit_dealloc( |
| 145 | &mut b, |
| 146 | &ctx.locals, |
| 147 | &ctx.locals, |
| 148 | type_layouts, |
| 149 | ctx.st, |
| 150 | ctx.internal_funcs, |
| 151 | Some(ctx.contained_host_refs), |
| 152 | None, |
| 153 | ); |
| 154 | } |
| 155 | ensure_termination(&mut b, None); |
| 156 | } |
| 157 | |
| 158 | module.add_function(func); |
| 159 | for pg in pending_globals { |
| 160 | module.add_global(pg.global); |
| 161 | } |
| 162 | |
| 163 | // Lower CONTAINS subprograms. Their host_decls chain is |
| 164 | // this unit's decls PLUS whatever we inherited from our |
| 165 | // own host (via `host_decls`). That way a nested contained |
| 166 | // proc can resolve names from any ancestor scope when |
| 167 | // build_host_ref_params looks up types. |
| 168 | let mut child_host_decls: Vec<crate::ast::decl::SpannedDecl> = decls.to_vec(); |
| 169 | child_host_decls.extend(host_decls.iter().cloned()); |
| 170 | for sub in contains { |
| 171 | lower_unit( |
| 172 | module, |
| 173 | sub, |
| 174 | st, |
| 175 | globals, |
| 176 | type_layouts, |
| 177 | &combined_uses, |
| 178 | &visible_param_consts, |
| 179 | &child_host_decls, |
| 180 | Some(body_fname.as_str()), |
| 181 | host_module, |
| 182 | alloc_return_funcs, |
| 183 | optional_params, |
| 184 | descriptor_params, |
| 185 | internal_funcs, |
| 186 | elemental_funcs, |
| 187 | char_len_star_params, |
| 188 | contained_host_refs, |
| 189 | ambiguous_use_warnings, |
| 190 | true, |
| 191 | ctx.proc_scope_id, |
| 192 | ); |
| 193 | } |
| 194 | } |
| 195 | ProgramUnit::Subroutine { |
| 196 | name, |
| 197 | decls, |
| 198 | body, |
| 199 | args, |
| 200 | bind, |
| 201 | uses, |
| 202 | contains, |
| 203 | prefix, |
| 204 | .. |
| 205 | } => { |
| 206 | // Sprint35-SMP Phase 2: separate-module-procedure body form. |
| 207 | // Parser emits args=[] and prefix=[Module]; sema injected the |
| 208 | // inherited dummies into the body scope. Two cases: |
| 209 | // |
| 210 | // 1. Parent interface declares a Function — build a |
| 211 | // synthetic ProgramUnit::Function and recurse into |
| 212 | // lower_unit so the Function arm handles result-var |
| 213 | // allocation, sret ABI, etc. |
| 214 | // 2. Parent declares a Subroutine — synthesize args+decls |
| 215 | // and continue down this Subroutine arm, which then |
| 216 | // walks them like a normal procedure. |
| 217 | if let Some(body_scope_id) = smp_body_proc_scope(st, name, args, prefix) { |
| 218 | if let Some(synth_unit) = try_synth_smp_function_unit( |
| 219 | st, |
| 220 | body_scope_id, |
| 221 | name, |
| 222 | bind, |
| 223 | prefix, |
| 224 | uses, |
| 225 | decls, |
| 226 | body, |
| 227 | contains, |
| 228 | unit.span, |
| 229 | ) { |
| 230 | let synth_spanned = crate::ast::Spanned::new(synth_unit, unit.span); |
| 231 | lower_unit( |
| 232 | module, |
| 233 | &synth_spanned, |
| 234 | st, |
| 235 | globals, |
| 236 | type_layouts, |
| 237 | host_uses, |
| 238 | host_param_consts, |
| 239 | host_decls, |
| 240 | host_link_name, |
| 241 | host_module, |
| 242 | alloc_return_funcs, |
| 243 | optional_params, |
| 244 | descriptor_params, |
| 245 | internal_funcs, |
| 246 | elemental_funcs, |
| 247 | char_len_star_params, |
| 248 | contained_host_refs, |
| 249 | ambiguous_use_warnings, |
| 250 | internal_only, |
| 251 | host_scope_id, |
| 252 | ); |
| 253 | return; |
| 254 | } |
| 255 | } |
| 256 | let smp_synth = smp_body_proc_scope(st, name, args, prefix) |
| 257 | .map(|sid| synthesize_smp_body_args_decls(st, sid, unit.span, decls)); |
| 258 | let args: &[crate::ast::unit::DummyArg] = match &smp_synth { |
| 259 | Some((sa, _)) => sa.as_slice(), |
| 260 | None => args.as_slice(), |
| 261 | }; |
| 262 | let decls: &[crate::ast::decl::SpannedDecl] = match &smp_synth { |
| 263 | Some((_, sd)) => sd.as_slice(), |
| 264 | None => decls.as_slice(), |
| 265 | }; |
| 266 | let func_name = lowered_procedure_symbol_name( |
| 267 | name, |
| 268 | bind.as_ref(), |
| 269 | host_link_name, |
| 270 | host_module, |
| 271 | internal_only, |
| 272 | internal_funcs, |
| 273 | ); |
| 274 | let proc_scope_id = |
| 275 | procedure_scope_for_dummy_args_with_host(st, name, args, host_scope_id); |
| 276 | let visible_param_consts = |
| 277 | collect_decl_param_consts_with_host(decls, host_param_consts); |
| 278 | let mut params: Vec<Param> = args |
| 279 | .iter() |
| 280 | .enumerate() |
| 281 | .filter_map(|(i, arg)| { |
| 282 | if let DummyArg::Name(n) = arg { |
| 283 | let elem_ty = arg_type_from_decls(n, decls, Some(st)); |
| 284 | let fortran_noalias = arg_is_fortran_noalias(n, decls); |
| 285 | let uses_descriptor = |
| 286 | arg_uses_descriptor_for_lowering(n, decls, st, proc_scope_id); |
| 287 | let uses_string_descriptor = |
| 288 | arg_uses_string_descriptor_from_decls(n, decls); |
| 289 | let is_derived = arg_derived_type_name(n, decls).is_some(); |
| 290 | if arg_has_value_attr(n, decls) { |
| 291 | // VALUE: pass by value (raw type, not pointer). |
| 292 | Some(Param { |
| 293 | name: n.clone(), |
| 294 | ty: elem_ty, |
| 295 | id: ValueId(i as u32), |
| 296 | fortran_noalias: false, |
| 297 | }) |
| 298 | } else { |
| 299 | Some(Param { |
| 300 | name: n.clone(), |
| 301 | ty: by_ref_storage_ir_type( |
| 302 | &elem_ty, |
| 303 | uses_descriptor, |
| 304 | uses_string_descriptor, |
| 305 | is_derived, |
| 306 | ), |
| 307 | id: ValueId(i as u32), |
| 308 | fortran_noalias, |
| 309 | }) |
| 310 | } |
| 311 | } else { |
| 312 | None |
| 313 | } |
| 314 | }) |
| 315 | .collect(); |
| 316 | // Append hidden-length i64 params for character(len=*) dummies. |
| 317 | // Per the standard Fortran ABI, these trail the normal params. |
| 318 | // |
| 319 | // Compute flags from this procedure's own decls — a bare-name |
| 320 | // lookup against `char_len_star_params` collides when several |
| 321 | // contained procedures across different hosts share an arg |
| 322 | // name (stdlib_sorting_sort has nine `helper`/`introsort`/etc |
| 323 | // contained sets, only the character variant declares |
| 324 | // `character(len=*)` actuals, but the map key is just |
| 325 | // "introsort"; without this the integer variants of |
| 326 | // `insertion_sort` would receive the char variant's flags and |
| 327 | // their bodies would lower as character arrays, calling |
| 328 | // `afs_compare_char` on integer data and silently failing to |
| 329 | // sort). |
| 330 | let mut hidden_len_params: Vec<(String, ValueId)> = Vec::new(); |
| 331 | let own_cls_flags = compute_char_len_star_flags(args, decls); |
| 332 | if own_cls_flags.iter().any(|f| *f) { |
| 333 | let normal_count = params.len(); |
| 334 | for (i, (flag, arg)) in own_cls_flags.iter().zip(args.iter()).enumerate() { |
| 335 | if *flag { |
| 336 | if let DummyArg::Name(n) = arg { |
| 337 | let hid_id = ValueId((normal_count + hidden_len_params.len()) as u32); |
| 338 | params.push(Param { |
| 339 | name: format!("__len_{}", n.to_lowercase()), |
| 340 | ty: IrType::Int(IntWidth::I64), |
| 341 | id: hid_id, |
| 342 | fortran_noalias: false, |
| 343 | }); |
| 344 | hidden_len_params.push((n.to_lowercase(), hid_id)); |
| 345 | } |
| 346 | } |
| 347 | let _ = i; |
| 348 | } |
| 349 | } |
| 350 | |
| 351 | // Host-association closure params. Trailing pointer params, |
| 352 | // one per host-local variable this contained proc reads or |
| 353 | // writes. Order matches contained_host_refs[name]. |
| 354 | let host_ref_infos = build_host_ref_params( |
| 355 | name, |
| 356 | host_decls, |
| 357 | host_param_consts, |
| 358 | contained_host_refs, |
| 359 | params.len() as u32, |
| 360 | st, |
| 361 | &mut params, |
| 362 | ); |
| 363 | |
| 364 | let mut func = Function::new(func_name.clone(), params, IrType::Void); |
| 365 | use crate::ast::unit::Prefix; |
| 366 | func.is_pure = prefix.iter().any(|p| matches!(p, Prefix::Pure)); |
| 367 | func.is_elemental = prefix.iter().any(|p| matches!(p, Prefix::Elemental)); |
| 368 | func.internal_only = internal_only; |
| 369 | let mut ctx = LowerCtx::new( |
| 370 | st, |
| 371 | globals, |
| 372 | type_layouts, |
| 373 | alloc_return_funcs, |
| 374 | optional_params, |
| 375 | descriptor_params, |
| 376 | internal_funcs, |
| 377 | elemental_funcs, |
| 378 | char_len_star_params, |
| 379 | contained_host_refs, |
| 380 | ambiguous_use_warnings.clone(), |
| 381 | ); |
| 382 | ctx.proc_scope_id = proc_scope_id; |
| 383 | let mut pending_globals: Vec<PendingGlobal> = Vec::new(); |
| 384 | let combined_uses: Vec<crate::ast::decl::SpannedDecl> = |
| 385 | host_uses.iter().chain(uses.iter()).cloned().collect(); |
| 386 | let required_import_names = collect_required_import_names(decls, body); |
| 387 | |
| 388 | // Collect param info: (name, param_id, elem_type, is_value). |
| 389 | // Skip hidden params: __len_* (character-length) and __host_* |
| 390 | // (host-association closure pointers) — they are installed |
| 391 | // by separate paths below. |
| 392 | let param_info: Vec<(String, ValueId, IrType, bool)> = func |
| 393 | .params |
| 394 | .iter() |
| 395 | .filter(|p| !p.name.starts_with("__len_") && !p.name.starts_with("__host_")) |
| 396 | .map(|p| { |
| 397 | let pname = p.name.to_lowercase(); |
| 398 | let elem_ty = arg_type_from_decls(&pname, decls, Some(st)); |
| 399 | let is_value = arg_has_value_attr(&pname, decls); |
| 400 | (pname, p.id, elem_ty, is_value) |
| 401 | }) |
| 402 | .collect(); |
| 403 | |
| 404 | { |
| 405 | let mut b = FuncBuilder::new(&mut func); |
| 406 | |
| 407 | // Set up hidden-length locals for assumed-len char dummies. |
| 408 | let mut hidden_len_addrs: HashMap<String, ValueId> = HashMap::new(); |
| 409 | for (hname, hid) in &hidden_len_params { |
| 410 | let slot = b.alloca(IrType::Int(IntWidth::I64)); |
| 411 | b.store(*hid, slot); |
| 412 | hidden_len_addrs.insert(hname.clone(), slot); |
| 413 | } |
| 414 | |
| 415 | for (pname, pid, elem_ty, is_value) in ¶m_info { |
| 416 | if *is_value { |
| 417 | let slot = b.alloca(elem_ty.clone()); |
| 418 | b.store(*pid, slot); |
| 419 | ctx.insert_scalar(pname.clone(), slot, elem_ty.clone()); |
| 420 | } else { |
| 421 | let uses_descriptor = arg_uses_descriptor_for_lowering( |
| 422 | pname, |
| 423 | decls, |
| 424 | st, |
| 425 | proc_scope_id, |
| 426 | ); |
| 427 | let uses_string_descriptor = |
| 428 | arg_uses_string_descriptor_from_decls(pname, decls); |
| 429 | let dt_name = arg_derived_type_name(pname, decls); |
| 430 | let is_pointer = decl_is_pointer(pname, decls); |
| 431 | let local_elem_ty = dummy_local_ir_type( |
| 432 | elem_ty, |
| 433 | dt_name.as_deref(), |
| 434 | is_pointer, |
| 435 | type_layouts, |
| 436 | ); |
| 437 | let slot = b.alloca(by_ref_storage_ir_type( |
| 438 | elem_ty, |
| 439 | uses_descriptor, |
| 440 | uses_string_descriptor, |
| 441 | dt_name.is_some(), |
| 442 | )); |
| 443 | b.store(*pid, slot); |
| 444 | // Check if this is a derived type parameter. |
| 445 | let ck = if let Some(&len_slot) = hidden_len_addrs.get(pname) { |
| 446 | CharKind::AssumedLen { len_addr: len_slot } |
| 447 | } else { |
| 448 | arg_char_kind_from_decls(pname, decls, st) |
| 449 | }; |
| 450 | let info = LocalInfo { |
| 451 | addr: slot, |
| 452 | ty: local_elem_ty, |
| 453 | dims: arg_dims_from_decls(pname, decls, &visible_param_consts, st), |
| 454 | allocatable: false, |
| 455 | descriptor_arg: uses_descriptor, |
| 456 | by_ref: true, |
| 457 | char_kind: ck, |
| 458 | derived_type: dt_name, |
| 459 | inline_const: None, |
| 460 | is_pointer, |
| 461 | runtime_dim_upper: vec![], |
| 462 | is_class: decl_is_class(pname, decls), |
| 463 | logical_kind: arg_logical_kind_from_decls( |
| 464 | pname, |
| 465 | decls, |
| 466 | Some(&visible_param_consts), |
| 467 | st, |
| 468 | ), |
| 469 | last_dim_assumed_size: arg_last_dim_assumed_size_from_decls(pname, decls), |
| 470 | }; |
| 471 | ctx.locals.insert(pname.clone(), info); |
| 472 | if decl_is_optional(pname, decls) { |
| 473 | ctx.optional_locals.insert(pname.clone()); |
| 474 | } |
| 475 | } |
| 476 | } |
| 477 | |
| 478 | for (pname, _, _, is_value) in ¶m_info { |
| 479 | if *is_value || hidden_len_addrs.contains_key(pname) { |
| 480 | continue; |
| 481 | } |
| 482 | let Some(len_expr) = arg_runtime_char_len_expr_from_decls(pname, decls, st) |
| 483 | else { |
| 484 | continue; |
| 485 | }; |
| 486 | let len_raw = super::expr::lower_expr_with_optional_layouts( |
| 487 | &mut b, |
| 488 | &ctx.locals, |
| 489 | &len_expr, |
| 490 | ctx.st, |
| 491 | Some(type_layouts), |
| 492 | ); |
| 493 | let len_addr = b.alloca(IrType::Int(IntWidth::I64)); |
| 494 | let len_val = clamp_nonnegative_i64(&mut b, len_raw); |
| 495 | b.store(len_val, len_addr); |
| 496 | if let Some(info) = ctx.locals.get_mut(pname) { |
| 497 | info.char_kind = CharKind::FixedRuntime { len_addr }; |
| 498 | } |
| 499 | } |
| 500 | // Explicit-shape dummies whose upper bound is itself |
| 501 | // a (non-const) dummy argument — e.g. `xs(n)` — need |
| 502 | // the bound evaluated at runtime on function entry. |
| 503 | // arg_dims_from_decls falls back to (1, 1) when the |
| 504 | // bound isn't const-foldable, which would produce |
| 505 | // spurious bounds-check failures. Walk every by_ref |
| 506 | // dummy, lower its bound expressions now (all other |
| 507 | // dummies are already in ctx.locals), and stash the |
| 508 | // i64 result into runtime_dim_upper. |
| 509 | install_runtime_dim_bounds( |
| 510 | &mut b, |
| 511 | &mut ctx.locals, |
| 512 | decls, |
| 513 | &visible_param_consts, |
| 514 | ctx.st, |
| 515 | type_layouts, |
| 516 | ); |
| 517 | install_assumed_shape_lower_overrides( |
| 518 | &mut b, |
| 519 | &mut ctx.locals, |
| 520 | decls, |
| 521 | &visible_param_consts, |
| 522 | ctx.st, |
| 523 | type_layouts, |
| 524 | ); |
| 525 | install_explicit_shape_dummy_rebase( |
| 526 | &mut b, |
| 527 | &mut ctx.locals, |
| 528 | decls, |
| 529 | &visible_param_consts, |
| 530 | ctx.st, |
| 531 | type_layouts, |
| 532 | ); |
| 533 | clear_intent_out_derived_params( |
| 534 | &mut b, |
| 535 | ¶m_info, |
| 536 | &ctx.locals, |
| 537 | decls, |
| 538 | type_layouts, |
| 539 | ); |
| 540 | |
| 541 | install_common_locals(&mut b, &mut ctx.locals, decls); |
| 542 | install_equivalence_locals(&mut b, &mut ctx.locals, decls, &visible_param_consts, st); |
| 543 | // Install host-association by_ref locals before alloc_decls |
| 544 | // so any same-named callee local (shouldn't occur per F |
| 545 | // scoping rules) is short-circuited, and so init_decls has |
| 546 | // them available for initialization expressions that |
| 547 | // reference host vars. |
| 548 | install_host_ref_locals(&mut b, &mut ctx.locals, &host_ref_infos); |
| 549 | super::alloc::alloc_decls( |
| 550 | &mut b, |
| 551 | &mut ctx.locals, |
| 552 | decls, |
| 553 | &visible_param_consts, |
| 554 | type_layouts, |
| 555 | &mut pending_globals, |
| 556 | &func_name, |
| 557 | st, |
| 558 | ); |
| 559 | install_host_param_consts(&mut b, &mut ctx.locals, host_param_consts, st); |
| 560 | install_globals_as_locals( |
| 561 | &mut b, |
| 562 | &mut ctx.locals, |
| 563 | globals, |
| 564 | &combined_uses, |
| 565 | Some(&required_import_names), |
| 566 | host_module, |
| 567 | ctx.st, |
| 568 | &ctx.ambiguous_use_warnings, |
| 569 | ); |
| 570 | ctx.filtered_names = compute_filtered_names(globals, &combined_uses, decls); |
| 571 | check_no_filtered_refs(body, &ctx.filtered_names); |
| 572 | collect_implicit_locals(&mut b, &mut ctx, body, UnitScope::Subroutine(name)); |
| 573 | super::init::init_decls(&mut b, &ctx.locals, decls, st, Some(type_layouts)); |
| 574 | // Pre-create blocks for all statement labels so GOTO can branch forward. |
| 575 | collect_label_blocks(&mut b, body, &mut ctx.label_blocks); |
| 576 | let _proc_scope_guard = ProcScopeGuard::enter(ctx.proc_scope_id); |
| 577 | super::stmt::lower_stmts(&mut b, &mut ctx, body); |
| 578 | drop(_proc_scope_guard); |
| 579 | if b.func().block(b.current_block()).terminator.is_none() { |
| 580 | insert_implicit_dealloc( |
| 581 | &mut b, |
| 582 | &ctx.locals, |
| 583 | &ctx.locals, |
| 584 | type_layouts, |
| 585 | ctx.st, |
| 586 | ctx.internal_funcs, |
| 587 | Some(ctx.contained_host_refs), |
| 588 | None, |
| 589 | ); |
| 590 | } |
| 591 | ensure_termination(&mut b, None); |
| 592 | } |
| 593 | |
| 594 | module.add_function(func); |
| 595 | for pg in pending_globals { |
| 596 | module.add_global(pg.global); |
| 597 | } |
| 598 | |
| 599 | // Lower nested CONTAINS subprograms (this was a latent |
| 600 | // bug — the previous code only walked Program::contains). |
| 601 | // Each nested sub inherits this subroutine's combined |
| 602 | // host_uses + own uses, and its host_decls chain is our |
| 603 | // `decls` followed by whatever host_decls we inherited — |
| 604 | // so a two-level-nested contained proc can look up host |
| 605 | // variables that live two scopes above it. |
| 606 | let mut child_host_decls: Vec<crate::ast::decl::SpannedDecl> = decls.to_vec(); |
| 607 | child_host_decls.extend(host_decls.iter().cloned()); |
| 608 | for sub in contains { |
| 609 | lower_unit( |
| 610 | module, |
| 611 | sub, |
| 612 | st, |
| 613 | globals, |
| 614 | type_layouts, |
| 615 | &combined_uses, |
| 616 | &visible_param_consts, |
| 617 | &child_host_decls, |
| 618 | Some(func_name.as_str()), |
| 619 | host_module, |
| 620 | alloc_return_funcs, |
| 621 | optional_params, |
| 622 | descriptor_params, |
| 623 | internal_funcs, |
| 624 | elemental_funcs, |
| 625 | char_len_star_params, |
| 626 | contained_host_refs, |
| 627 | ambiguous_use_warnings, |
| 628 | true, |
| 629 | proc_scope_id, |
| 630 | ); |
| 631 | } |
| 632 | } |
| 633 | ProgramUnit::Function { |
| 634 | name, |
| 635 | decls, |
| 636 | body, |
| 637 | args, |
| 638 | result, |
| 639 | return_type, |
| 640 | bind, |
| 641 | uses, |
| 642 | contains, |
| 643 | prefix, |
| 644 | .. |
| 645 | } => { |
| 646 | let func_name = lowered_procedure_symbol_name( |
| 647 | name, |
| 648 | bind.as_ref(), |
| 649 | host_link_name, |
| 650 | host_module, |
| 651 | internal_only, |
| 652 | internal_funcs, |
| 653 | ); |
| 654 | let proc_scope_id = |
| 655 | procedure_scope_for_dummy_args_with_host(st, name, args, host_scope_id); |
| 656 | let visible_param_consts = |
| 657 | collect_decl_param_consts_with_host(decls, host_param_consts); |
| 658 | |
| 659 | // Hidden-result ABI: allocatable arrays use a 384-byte array |
| 660 | // descriptor, while scalar character results use a 32-byte |
| 661 | // string descriptor. In both cases the caller provides the |
| 662 | // descriptor storage as param 0 and the callee returns void. |
| 663 | let hidden_result_abi = function_hidden_result_abi( |
| 664 | name, |
| 665 | result, |
| 666 | return_type.as_ref(), |
| 667 | decls, |
| 668 | bind.as_ref(), |
| 669 | ); |
| 670 | let uses_hidden_result = hidden_result_abi != HiddenResultAbi::None; |
| 671 | |
| 672 | let (func_params, ir_ret_ty) = if uses_hidden_result { |
| 673 | let desc_size = match hidden_result_abi { |
| 674 | HiddenResultAbi::ArrayDescriptor => 384, |
| 675 | HiddenResultAbi::StringDescriptor => 32, |
| 676 | HiddenResultAbi::DerivedAggregate => { |
| 677 | let result_name = result |
| 678 | .as_deref() |
| 679 | .unwrap_or(name.as_str()) |
| 680 | .to_lowercase(); |
| 681 | derived_type_name_for_result_var(return_type, &result_name, decls) |
| 682 | .and_then(|dt_name| type_layouts.get(&dt_name).map(|layout| layout.size.max(1) as u64)) |
| 683 | .unwrap_or(8) |
| 684 | } |
| 685 | HiddenResultAbi::ComplexBuffer => { |
| 686 | // 8 bytes for complex(sp), 16 for complex(dp). |
| 687 | let kind = super::core::complex_result_kind( |
| 688 | name, |
| 689 | result, |
| 690 | return_type.as_ref(), |
| 691 | decls, |
| 692 | st, |
| 693 | ); |
| 694 | if kind == 8 { |
| 695 | 16 |
| 696 | } else { |
| 697 | 8 |
| 698 | } |
| 699 | } |
| 700 | HiddenResultAbi::None => 0, |
| 701 | }; |
| 702 | let desc_ptr_ty = IrType::Ptr(Box::new(IrType::Array( |
| 703 | Box::new(IrType::Int(IntWidth::I8)), |
| 704 | desc_size, |
| 705 | ))); |
| 706 | let sret = Param { |
| 707 | name: "_sret".into(), |
| 708 | ty: desc_ptr_ty, |
| 709 | id: ValueId(0), |
| 710 | fortran_noalias: false, |
| 711 | }; |
| 712 | // Real args shifted by 1 so _sret is param 0. |
| 713 | let real: Vec<Param> = args |
| 714 | .iter() |
| 715 | .enumerate() |
| 716 | .filter_map(|(i, arg)| { |
| 717 | if let DummyArg::Name(n) = arg { |
| 718 | let elem_ty = arg_type_from_decls(n, decls, Some(st)); |
| 719 | let fortran_noalias = arg_is_fortran_noalias(n, decls); |
| 720 | let uses_descriptor = |
| 721 | arg_uses_descriptor_for_lowering(n, decls, st, proc_scope_id); |
| 722 | let uses_string_descriptor = |
| 723 | arg_uses_string_descriptor_from_decls(n, decls); |
| 724 | let is_derived = arg_derived_type_name(n, decls).is_some(); |
| 725 | if arg_has_value_attr(n, decls) { |
| 726 | Some(Param { |
| 727 | name: n.clone(), |
| 728 | ty: elem_ty, |
| 729 | id: ValueId(i as u32 + 1), |
| 730 | fortran_noalias: false, |
| 731 | }) |
| 732 | } else { |
| 733 | Some(Param { |
| 734 | name: n.clone(), |
| 735 | ty: by_ref_storage_ir_type( |
| 736 | &elem_ty, |
| 737 | uses_descriptor, |
| 738 | uses_string_descriptor, |
| 739 | is_derived, |
| 740 | ), |
| 741 | id: ValueId(i as u32 + 1), |
| 742 | fortran_noalias, |
| 743 | }) |
| 744 | } |
| 745 | } else { |
| 746 | None |
| 747 | } |
| 748 | }) |
| 749 | .collect(); |
| 750 | let mut params = vec![sret]; |
| 751 | params.extend(real); |
| 752 | (params, IrType::Void) |
| 753 | } else { |
| 754 | let result_name = result.as_deref().unwrap_or(name.as_str()); |
| 755 | let result_is_pointer = decl_is_pointer(result_name, decls); |
| 756 | let mut ret_ty = if bind.is_some() |
| 757 | && matches!(return_type.as_ref(), Some(TypeSpec::Character(_))) |
| 758 | { |
| 759 | IrType::Int(IntWidth::I8) |
| 760 | } else { |
| 761 | return_type |
| 762 | .as_ref() |
| 763 | .map(|ts| lower_type_spec_st(ts, Some(st))) |
| 764 | .unwrap_or_else(|| arg_type_from_decls(result_name, decls, Some(st))) |
| 765 | }; |
| 766 | if result_is_pointer && !ret_ty.is_ptr() { |
| 767 | ret_ty = IrType::Ptr(Box::new(ret_ty)); |
| 768 | } |
| 769 | let params: Vec<Param> = args |
| 770 | .iter() |
| 771 | .enumerate() |
| 772 | .filter_map(|(i, arg)| { |
| 773 | if let DummyArg::Name(n) = arg { |
| 774 | let elem_ty = arg_type_from_decls(n, decls, Some(st)); |
| 775 | let fortran_noalias = arg_is_fortran_noalias(n, decls); |
| 776 | let uses_descriptor = |
| 777 | arg_uses_descriptor_for_lowering(n, decls, st, proc_scope_id); |
| 778 | let uses_string_descriptor = |
| 779 | arg_uses_string_descriptor_from_decls(n, decls); |
| 780 | let is_derived = arg_derived_type_name(n, decls).is_some(); |
| 781 | if arg_has_value_attr(n, decls) { |
| 782 | Some(Param { |
| 783 | name: n.clone(), |
| 784 | ty: elem_ty, |
| 785 | id: ValueId(i as u32), |
| 786 | fortran_noalias: false, |
| 787 | }) |
| 788 | } else { |
| 789 | Some(Param { |
| 790 | name: n.clone(), |
| 791 | ty: by_ref_storage_ir_type( |
| 792 | &elem_ty, |
| 793 | uses_descriptor, |
| 794 | uses_string_descriptor, |
| 795 | is_derived, |
| 796 | ), |
| 797 | id: ValueId(i as u32), |
| 798 | fortran_noalias, |
| 799 | }) |
| 800 | } |
| 801 | } else { |
| 802 | None |
| 803 | } |
| 804 | }) |
| 805 | .collect(); |
| 806 | (params, ret_ty) |
| 807 | }; |
| 808 | |
| 809 | // Host-association closure params for contained functions. |
| 810 | // Trailing pointer params, one per host-local variable the |
| 811 | // body reads or writes. See `build_host_ref_params`. |
| 812 | let mut func_params = func_params; |
| 813 | let mut hidden_len_params: Vec<(String, ValueId)> = Vec::new(); |
| 814 | // See sister site above for why we compute from decls |
| 815 | // instead of looking up the bare-name map. |
| 816 | let own_cls_flags = compute_char_len_star_flags(args, decls); |
| 817 | if own_cls_flags.iter().any(|f| *f) { |
| 818 | let normal_count = func_params.len(); |
| 819 | for (flag, arg) in own_cls_flags.iter().zip(args.iter()) { |
| 820 | if *flag { |
| 821 | if let DummyArg::Name(n) = arg { |
| 822 | let hid_id = ValueId((normal_count + hidden_len_params.len()) as u32); |
| 823 | func_params.push(Param { |
| 824 | name: format!("__len_{}", n.to_lowercase()), |
| 825 | ty: IrType::Int(IntWidth::I64), |
| 826 | id: hid_id, |
| 827 | fortran_noalias: false, |
| 828 | }); |
| 829 | hidden_len_params.push((n.to_lowercase(), hid_id)); |
| 830 | } |
| 831 | } |
| 832 | } |
| 833 | } |
| 834 | let host_ref_infos = build_host_ref_params( |
| 835 | name, |
| 836 | host_decls, |
| 837 | host_param_consts, |
| 838 | contained_host_refs, |
| 839 | func_params.len() as u32, |
| 840 | st, |
| 841 | &mut func_params, |
| 842 | ); |
| 843 | |
| 844 | let mut func = Function::new(func_name.clone(), func_params, ir_ret_ty.clone()); |
| 845 | // Propagate PURE/ELEMENTAL from AST prefix. |
| 846 | use crate::ast::unit::Prefix; |
| 847 | func.is_pure = prefix.iter().any(|p| matches!(p, Prefix::Pure)); |
| 848 | func.is_elemental = prefix.iter().any(|p| matches!(p, Prefix::Elemental)); |
| 849 | func.internal_only = internal_only; |
| 850 | let mut ctx = LowerCtx::new( |
| 851 | st, |
| 852 | globals, |
| 853 | type_layouts, |
| 854 | alloc_return_funcs, |
| 855 | optional_params, |
| 856 | descriptor_params, |
| 857 | internal_funcs, |
| 858 | elemental_funcs, |
| 859 | char_len_star_params, |
| 860 | contained_host_refs, |
| 861 | ambiguous_use_warnings.clone(), |
| 862 | ); |
| 863 | ctx.proc_scope_id = proc_scope_id; |
| 864 | let mut pending_globals: Vec<PendingGlobal> = Vec::new(); |
| 865 | let combined_uses: Vec<crate::ast::decl::SpannedDecl> = |
| 866 | host_uses.iter().chain(uses.iter()).cloned().collect(); |
| 867 | let required_import_names = collect_required_import_names(decls, body); |
| 868 | |
| 869 | // Build param_info skipping the sret param (not a Fortran |
| 870 | // variable) and __host_* closure-passing pointers (installed |
| 871 | // via install_host_ref_locals below). |
| 872 | let param_info: Vec<(String, ValueId, IrType, bool)> = func |
| 873 | .params |
| 874 | .iter() |
| 875 | .filter(|p| { |
| 876 | p.name != "_sret" |
| 877 | && !p.name.starts_with("__len_") |
| 878 | && !p.name.starts_with("__host_") |
| 879 | }) |
| 880 | .map(|p| { |
| 881 | let pname = p.name.to_lowercase(); |
| 882 | let elem_ty = arg_type_from_decls(&pname, decls, Some(st)); |
| 883 | let is_value = arg_has_value_attr(&pname, decls); |
| 884 | (pname, p.id, elem_ty, is_value) |
| 885 | }) |
| 886 | .collect(); |
| 887 | |
| 888 | { |
| 889 | let mut b = FuncBuilder::new(&mut func); |
| 890 | |
| 891 | let mut hidden_len_addrs: HashMap<String, ValueId> = HashMap::new(); |
| 892 | for (hname, hid) in &hidden_len_params { |
| 893 | let slot = b.alloca(IrType::Int(IntWidth::I64)); |
| 894 | b.store(*hid, slot); |
| 895 | hidden_len_addrs.insert(hname.clone(), slot); |
| 896 | } |
| 897 | |
| 898 | for (pname, pid, elem_ty, is_value) in ¶m_info { |
| 899 | if *is_value { |
| 900 | let slot = b.alloca(elem_ty.clone()); |
| 901 | b.store(*pid, slot); |
| 902 | ctx.insert_scalar(pname.clone(), slot, elem_ty.clone()); |
| 903 | } else { |
| 904 | let uses_descriptor = arg_uses_descriptor_for_lowering( |
| 905 | pname, |
| 906 | decls, |
| 907 | st, |
| 908 | proc_scope_id, |
| 909 | ); |
| 910 | let uses_string_descriptor = |
| 911 | arg_uses_string_descriptor_from_decls(pname, decls); |
| 912 | let dt_name = arg_derived_type_name(pname, decls); |
| 913 | let is_pointer = decl_is_pointer(pname, decls); |
| 914 | let local_elem_ty = dummy_local_ir_type( |
| 915 | elem_ty, |
| 916 | dt_name.as_deref(), |
| 917 | is_pointer, |
| 918 | type_layouts, |
| 919 | ); |
| 920 | let slot = b.alloca(by_ref_storage_ir_type( |
| 921 | elem_ty, |
| 922 | uses_descriptor, |
| 923 | uses_string_descriptor, |
| 924 | dt_name.is_some(), |
| 925 | )); |
| 926 | b.store(*pid, slot); |
| 927 | let ck = if let Some(&len_slot) = hidden_len_addrs.get(pname) { |
| 928 | CharKind::AssumedLen { len_addr: len_slot } |
| 929 | } else { |
| 930 | arg_char_kind_from_decls(pname, decls, st) |
| 931 | }; |
| 932 | ctx.locals.insert( |
| 933 | pname.clone(), |
| 934 | LocalInfo { |
| 935 | addr: slot, |
| 936 | ty: local_elem_ty, |
| 937 | dims: arg_dims_from_decls(pname, decls, &visible_param_consts, st), |
| 938 | allocatable: false, |
| 939 | descriptor_arg: uses_descriptor, |
| 940 | by_ref: true, |
| 941 | char_kind: ck, |
| 942 | derived_type: dt_name, |
| 943 | inline_const: None, |
| 944 | is_pointer, |
| 945 | runtime_dim_upper: vec![], |
| 946 | is_class: decl_is_class(pname, decls), |
| 947 | logical_kind: arg_logical_kind_from_decls( |
| 948 | pname, |
| 949 | decls, |
| 950 | Some(&visible_param_consts), |
| 951 | st, |
| 952 | ), |
| 953 | last_dim_assumed_size: arg_last_dim_assumed_size_from_decls(pname, decls), |
| 954 | }, |
| 955 | ); |
| 956 | if decl_is_optional(pname, decls) { |
| 957 | ctx.optional_locals.insert(pname.clone()); |
| 958 | } |
| 959 | } |
| 960 | } |
| 961 | |
| 962 | for (pname, _, _, is_value) in ¶m_info { |
| 963 | if *is_value || hidden_len_addrs.contains_key(pname) { |
| 964 | continue; |
| 965 | } |
| 966 | let Some(len_expr) = arg_runtime_char_len_expr_from_decls(pname, decls, st) |
| 967 | else { |
| 968 | continue; |
| 969 | }; |
| 970 | let len_raw = super::expr::lower_expr(&mut b, &ctx.locals, &len_expr, ctx.st); |
| 971 | let len_addr = b.alloca(IrType::Int(IntWidth::I64)); |
| 972 | let len_val = clamp_nonnegative_i64(&mut b, len_raw); |
| 973 | b.store(len_val, len_addr); |
| 974 | if let Some(info) = ctx.locals.get_mut(pname) { |
| 975 | info.char_kind = CharKind::FixedRuntime { len_addr }; |
| 976 | } |
| 977 | } |
| 978 | install_runtime_dim_bounds( |
| 979 | &mut b, |
| 980 | &mut ctx.locals, |
| 981 | decls, |
| 982 | &visible_param_consts, |
| 983 | ctx.st, |
| 984 | type_layouts, |
| 985 | ); |
| 986 | install_assumed_shape_lower_overrides( |
| 987 | &mut b, |
| 988 | &mut ctx.locals, |
| 989 | decls, |
| 990 | &visible_param_consts, |
| 991 | ctx.st, |
| 992 | type_layouts, |
| 993 | ); |
| 994 | install_explicit_shape_dummy_rebase( |
| 995 | &mut b, |
| 996 | &mut ctx.locals, |
| 997 | decls, |
| 998 | &visible_param_consts, |
| 999 | ctx.st, |
| 1000 | type_layouts, |
| 1001 | ); |
| 1002 | clear_intent_out_derived_params( |
| 1003 | &mut b, |
| 1004 | ¶m_info, |
| 1005 | &ctx.locals, |
| 1006 | decls, |
| 1007 | type_layouts, |
| 1008 | ); |
| 1009 | |
| 1010 | let result_name = result.as_deref().unwrap_or(name.as_str()).to_lowercase(); |
| 1011 | ctx.result_name = Some(result_name.clone()); |
| 1012 | ctx.hidden_result_abi = hidden_result_abi; |
| 1013 | |
| 1014 | let result_is_pointer = decl_is_pointer(&result_name, decls); |
| 1015 | |
| 1016 | if hidden_result_abi == HiddenResultAbi::ArrayDescriptor { |
| 1017 | // The hidden first param is the caller-provided array descriptor. |
| 1018 | let result_char_kind = arg_char_kind_from_decls(&result_name, decls, st); |
| 1019 | let elem_ty = match result_char_kind { |
| 1020 | CharKind::Fixed(len) => fixed_char_storage_ir_type(len), |
| 1021 | _ => arg_type_from_decls(&result_name, decls, Some(st)), |
| 1022 | }; |
| 1023 | let result_derived_type = arg_derived_type_name(&result_name, decls); |
| 1024 | let local_elem_ty = derived_local_storage_ir_type( |
| 1025 | &elem_ty, |
| 1026 | result_derived_type.as_deref(), |
| 1027 | type_layouts, |
| 1028 | ); |
| 1029 | let result_dims = |
| 1030 | arg_dims_from_decls(&result_name, decls, &visible_param_consts, st); |
| 1031 | ctx.locals.insert( |
| 1032 | result_name.clone(), |
| 1033 | LocalInfo { |
| 1034 | addr: ValueId(0), |
| 1035 | ty: local_elem_ty, |
| 1036 | dims: result_dims, |
| 1037 | allocatable: true, |
| 1038 | descriptor_arg: false, |
| 1039 | by_ref: false, |
| 1040 | char_kind: result_char_kind, |
| 1041 | derived_type: result_derived_type, |
| 1042 | inline_const: None, |
| 1043 | is_pointer: false, |
| 1044 | runtime_dim_upper: vec![], |
| 1045 | is_class: false, |
| 1046 | logical_kind: None, |
| 1047 | last_dim_assumed_size: false, |
| 1048 | }, |
| 1049 | ); |
| 1050 | } else if hidden_result_abi == HiddenResultAbi::DerivedAggregate { |
| 1051 | let dt_name = derived_type_name_for_result_var( |
| 1052 | return_type, |
| 1053 | &result_name, |
| 1054 | decls, |
| 1055 | ) |
| 1056 | .expect("derived hidden-result function missing result type"); |
| 1057 | if let Some(layout) = type_layouts.get(&dt_name) { |
| 1058 | if derived_layout_needs_runtime_initialization(layout, type_layouts) { |
| 1059 | initialize_derived_storage(&mut b, ValueId(0), layout, type_layouts); |
| 1060 | } |
| 1061 | } |
| 1062 | ctx.locals.insert( |
| 1063 | result_name.clone(), |
| 1064 | LocalInfo { |
| 1065 | addr: ValueId(0), |
| 1066 | ty: IrType::Ptr(Box::new(IrType::Int(IntWidth::I8))), |
| 1067 | dims: vec![], |
| 1068 | allocatable: false, |
| 1069 | descriptor_arg: false, |
| 1070 | by_ref: false, |
| 1071 | char_kind: CharKind::None, |
| 1072 | derived_type: Some(dt_name), |
| 1073 | inline_const: None, |
| 1074 | is_pointer: false, |
| 1075 | runtime_dim_upper: vec![], |
| 1076 | is_class: false, |
| 1077 | logical_kind: None, |
| 1078 | last_dim_assumed_size: false, |
| 1079 | }, |
| 1080 | ); |
| 1081 | ctx.result_addr = Some(ValueId(0)); |
| 1082 | ctx.result_type = Some(IrType::Ptr(Box::new(IrType::Int(IntWidth::I8)))); |
| 1083 | } else if hidden_result_abi == HiddenResultAbi::ComplexBuffer { |
| 1084 | // The hidden first param is the caller-allocated complex |
| 1085 | // buffer typed as `Ptr<[i8 x 8/16]>` so the call-site IR |
| 1086 | // type matches the caller's byte-buffer alloca. The body |
| 1087 | // needs a *typed* complex pointer (`Ptr<[Float x 2]>`) |
| 1088 | // for two reasons: |
| 1089 | // 1. The complex-assign path stores two Float lanes — |
| 1090 | // a typed pointer keeps load/store types consistent |
| 1091 | // with the IR verifier. |
| 1092 | // 2. Generic dispatch on the result variable consults |
| 1093 | // `b.func().value_type(addr)` to match candidates; |
| 1094 | // a `Ptr<[Float x 2]>` is recognised as complex, |
| 1095 | // while `Ptr<[i8 x 8]>` matches no complex formal. |
| 1096 | // GEP at byte offset 0 with a Float-array result type |
| 1097 | // produces the typed view without changing the runtime |
| 1098 | // address. |
| 1099 | let kind = super::core::complex_result_kind( |
| 1100 | name, |
| 1101 | result, |
| 1102 | return_type.as_ref(), |
| 1103 | decls, |
| 1104 | st, |
| 1105 | ); |
| 1106 | let fw = if kind == 8 { FloatWidth::F64 } else { FloatWidth::F32 }; |
| 1107 | let cplx_ty = IrType::Array(Box::new(IrType::Float(fw)), 2); |
| 1108 | let zero_off = b.const_i64(0); |
| 1109 | let typed_addr = b.gep(ValueId(0), vec![zero_off], cplx_ty.clone()); |
| 1110 | ctx.locals.insert( |
| 1111 | result_name.clone(), |
| 1112 | LocalInfo { |
| 1113 | addr: typed_addr, |
| 1114 | ty: cplx_ty.clone(), |
| 1115 | dims: vec![], |
| 1116 | allocatable: false, |
| 1117 | descriptor_arg: false, |
| 1118 | by_ref: false, |
| 1119 | char_kind: CharKind::None, |
| 1120 | derived_type: None, |
| 1121 | inline_const: None, |
| 1122 | is_pointer: false, |
| 1123 | runtime_dim_upper: vec![], |
| 1124 | is_class: false, |
| 1125 | logical_kind: None, |
| 1126 | last_dim_assumed_size: false, |
| 1127 | }, |
| 1128 | ); |
| 1129 | ctx.result_addr = Some(typed_addr); |
| 1130 | ctx.result_type = Some(IrType::Ptr(Box::new(cplx_ty))); |
| 1131 | } else if hidden_result_abi == HiddenResultAbi::StringDescriptor { |
| 1132 | // Scalar character results use the hidden StringDescriptor |
| 1133 | // ABI, but the body still writes to a normal local result |
| 1134 | // variable. We materialize that local through alloc_decls |
| 1135 | // / ensure_hidden_string_result_local below and copy it |
| 1136 | // into the hidden descriptor right before return. |
| 1137 | } else if result_is_pointer { |
| 1138 | let result_addr = b.alloca(ir_ret_ty.clone()); |
| 1139 | let zero_byte = b.const_i32(0); |
| 1140 | let eight = b.const_i64(8); |
| 1141 | b.call( |
| 1142 | FuncRef::External("memset".into()), |
| 1143 | vec![result_addr, zero_byte, eight], |
| 1144 | IrType::Ptr(Box::new(IrType::Int(IntWidth::I8))), |
| 1145 | ); |
| 1146 | ctx.locals.insert( |
| 1147 | result_name.clone(), |
| 1148 | LocalInfo { |
| 1149 | addr: result_addr, |
| 1150 | ty: match &ir_ret_ty { |
| 1151 | IrType::Ptr(elem) => (**elem).clone(), |
| 1152 | other => other.clone(), |
| 1153 | }, |
| 1154 | dims: vec![], |
| 1155 | allocatable: false, |
| 1156 | descriptor_arg: false, |
| 1157 | by_ref: false, |
| 1158 | char_kind: CharKind::None, |
| 1159 | derived_type: derived_type_name_for_result_var( |
| 1160 | return_type, |
| 1161 | &result_name, |
| 1162 | decls, |
| 1163 | ), |
| 1164 | inline_const: None, |
| 1165 | is_pointer: true, |
| 1166 | runtime_dim_upper: vec![], |
| 1167 | is_class: false, |
| 1168 | logical_kind: None, |
| 1169 | last_dim_assumed_size: false, |
| 1170 | }, |
| 1171 | ); |
| 1172 | ctx.result_addr = Some(result_addr); |
| 1173 | ctx.result_type = Some(ir_ret_ty.clone()); |
| 1174 | } else if let Some(dt_name) = |
| 1175 | derived_type_name_for_result_var(return_type, &result_name, decls) |
| 1176 | { |
| 1177 | // Derived-type FUNCTION result: allocate a struct-shaped |
| 1178 | // buffer ([i8 x layout.size]) and register the result |
| 1179 | // variable with `derived_type = Some(name)` so component |
| 1180 | // access (e.g. `vec_add%x = ...`) lands on the buffer. |
| 1181 | // Without this, the generic `b.alloca(ir_ret_ty)` path |
| 1182 | // allocates a `ptr<ptr<i8>>` slot, ComponentAccess can't |
| 1183 | // resolve the type name, and every assignment to the |
| 1184 | // result variable is silently dropped. derived_type_name_ |
| 1185 | // for_result_var accepts both header-level (`type(t) |
| 1186 | // function f`) and body-level (`function f result(r); |
| 1187 | // type(t) :: r`) declarations. |
| 1188 | let layout = type_layouts.get(&dt_name); |
| 1189 | let size = layout.map(|l| l.size as u64).unwrap_or(8); |
| 1190 | let buf_ty = IrType::Array(Box::new(IrType::Int(IntWidth::I8)), size); |
| 1191 | let result_addr = b.alloca(buf_ty); |
| 1192 | if let Some(layout) = layout { |
| 1193 | if derived_layout_needs_runtime_initialization(layout, type_layouts) { |
| 1194 | initialize_derived_storage(&mut b, result_addr, layout, type_layouts); |
| 1195 | } |
| 1196 | } |
| 1197 | ctx.locals.insert( |
| 1198 | result_name.clone(), |
| 1199 | LocalInfo { |
| 1200 | addr: result_addr, |
| 1201 | ty: IrType::Ptr(Box::new(IrType::Int(IntWidth::I8))), |
| 1202 | dims: vec![], |
| 1203 | allocatable: false, |
| 1204 | descriptor_arg: false, |
| 1205 | by_ref: false, |
| 1206 | char_kind: CharKind::None, |
| 1207 | derived_type: Some(dt_name), |
| 1208 | inline_const: None, |
| 1209 | is_pointer: false, |
| 1210 | runtime_dim_upper: vec![], |
| 1211 | is_class: false, |
| 1212 | logical_kind: None, |
| 1213 | last_dim_assumed_size: false, |
| 1214 | }, |
| 1215 | ); |
| 1216 | ctx.result_addr = Some(result_addr); |
| 1217 | ctx.result_type = Some(IrType::Ptr(Box::new(IrType::Int(IntWidth::I8)))); |
| 1218 | } else { |
| 1219 | let result_addr = b.alloca(ir_ret_ty.clone()); |
| 1220 | ctx.insert_scalar(result_name.clone(), result_addr, ir_ret_ty.clone()); |
| 1221 | ctx.result_addr = Some(result_addr); |
| 1222 | ctx.result_type = Some(ir_ret_ty.clone()); |
| 1223 | } |
| 1224 | |
| 1225 | install_common_locals(&mut b, &mut ctx.locals, decls); |
| 1226 | install_equivalence_locals(&mut b, &mut ctx.locals, decls, &visible_param_consts, st); |
| 1227 | install_host_ref_locals(&mut b, &mut ctx.locals, &host_ref_infos); |
| 1228 | super::alloc::alloc_decls( |
| 1229 | &mut b, |
| 1230 | &mut ctx.locals, |
| 1231 | decls, |
| 1232 | &visible_param_consts, |
| 1233 | type_layouts, |
| 1234 | &mut pending_globals, |
| 1235 | &func_name, |
| 1236 | st, |
| 1237 | ); |
| 1238 | if hidden_result_abi == HiddenResultAbi::StringDescriptor { |
| 1239 | ensure_hidden_string_result_local( |
| 1240 | &mut b, |
| 1241 | &mut ctx.locals, |
| 1242 | &result_name, |
| 1243 | return_type.as_ref(), |
| 1244 | &visible_param_consts, |
| 1245 | st, |
| 1246 | ); |
| 1247 | } |
| 1248 | install_host_param_consts(&mut b, &mut ctx.locals, host_param_consts, st); |
| 1249 | install_globals_as_locals( |
| 1250 | &mut b, |
| 1251 | &mut ctx.locals, |
| 1252 | globals, |
| 1253 | &combined_uses, |
| 1254 | Some(&required_import_names), |
| 1255 | host_module, |
| 1256 | ctx.st, |
| 1257 | &ctx.ambiguous_use_warnings, |
| 1258 | ); |
| 1259 | ctx.filtered_names = compute_filtered_names(globals, &combined_uses, decls); |
| 1260 | check_no_filtered_refs(body, &ctx.filtered_names); |
| 1261 | collect_implicit_locals(&mut b, &mut ctx, body, UnitScope::Function(name)); |
| 1262 | super::init::init_decls(&mut b, &ctx.locals, decls, st, Some(type_layouts)); |
| 1263 | if hidden_result_abi == HiddenResultAbi::ArrayDescriptor { |
| 1264 | if let Some(info) = ctx.locals.get(&result_name).cloned() { |
| 1265 | if !info.allocatable || info.is_pointer { |
| 1266 | // Already handled above by attribute exclusion. |
| 1267 | } |
| 1268 | allocate_runtime_shape_array_result( |
| 1269 | &mut b, |
| 1270 | &ctx.locals, |
| 1271 | &result_name, |
| 1272 | ValueId(0), |
| 1273 | &info.ty, |
| 1274 | decls, |
| 1275 | &visible_param_consts, |
| 1276 | ctx.st, |
| 1277 | type_layouts, |
| 1278 | ); |
| 1279 | } |
| 1280 | } |
| 1281 | collect_label_blocks(&mut b, body, &mut ctx.label_blocks); |
| 1282 | let _proc_scope_guard = ProcScopeGuard::enter(ctx.proc_scope_id); |
| 1283 | super::stmt::lower_stmts(&mut b, &mut ctx, body); |
| 1284 | drop(_proc_scope_guard); |
| 1285 | |
| 1286 | if b.func().block(b.current_block()).terminator.is_none() { |
| 1287 | if hidden_result_abi == HiddenResultAbi::StringDescriptor { |
| 1288 | lower_hidden_string_result_copy(&mut b, &ctx); |
| 1289 | } |
| 1290 | let result_is_pointer = ctx |
| 1291 | .locals |
| 1292 | .get(&result_name) |
| 1293 | .map(|info| info.is_pointer) |
| 1294 | .unwrap_or(false); |
| 1295 | let derived_result_type = |
| 1296 | derived_type_name_for_result_var(return_type, &result_name, decls); |
| 1297 | let skip = if matches!( |
| 1298 | hidden_result_abi, |
| 1299 | HiddenResultAbi::ArrayDescriptor | HiddenResultAbi::DerivedAggregate |
| 1300 | ) { |
| 1301 | Some(ValueId(0)) |
| 1302 | } else if !result_is_pointer && derived_result_type.is_some() { |
| 1303 | ctx.result_addr |
| 1304 | } else { |
| 1305 | None |
| 1306 | }; |
| 1307 | insert_implicit_dealloc( |
| 1308 | &mut b, |
| 1309 | &ctx.locals, |
| 1310 | &ctx.locals, |
| 1311 | type_layouts, |
| 1312 | ctx.st, |
| 1313 | ctx.internal_funcs, |
| 1314 | Some(ctx.contained_host_refs), |
| 1315 | skip, |
| 1316 | ); |
| 1317 | if uses_hidden_result { |
| 1318 | b.ret(None); |
| 1319 | } else if !result_is_pointer && derived_result_type.is_some() { |
| 1320 | // Derived-type result: return the buffer |
| 1321 | // address as a Ptr(i8) (the declared return |
| 1322 | // type). A zero-offset GEP through `i8` |
| 1323 | // reshapes Ptr(Array(i8, N)) into Ptr(i8). |
| 1324 | let result_addr = ctx |
| 1325 | .result_addr |
| 1326 | .expect("derived-return function has result_addr"); |
| 1327 | let zero = b.const_i64(0); |
| 1328 | let byte_ptr = b.gep(result_addr, vec![zero], IrType::Int(IntWidth::I8)); |
| 1329 | b.ret(Some(byte_ptr)); |
| 1330 | } else { |
| 1331 | let result_addr = |
| 1332 | ctx.result_addr.expect("non-sret function has result_addr"); |
| 1333 | let rv = b.load(result_addr); |
| 1334 | b.ret(Some(rv)); |
| 1335 | } |
| 1336 | } |
| 1337 | } |
| 1338 | |
| 1339 | module.add_function(func); |
| 1340 | for pg in pending_globals { |
| 1341 | module.add_global(pg.global); |
| 1342 | } |
| 1343 | |
| 1344 | // Lower nested CONTAINS subprograms with the accumulated |
| 1345 | // host_decls chain (our decls + inherited). |
| 1346 | let mut child_host_decls: Vec<crate::ast::decl::SpannedDecl> = decls.to_vec(); |
| 1347 | child_host_decls.extend(host_decls.iter().cloned()); |
| 1348 | for sub in contains { |
| 1349 | lower_unit( |
| 1350 | module, |
| 1351 | sub, |
| 1352 | st, |
| 1353 | globals, |
| 1354 | type_layouts, |
| 1355 | &combined_uses, |
| 1356 | &visible_param_consts, |
| 1357 | &child_host_decls, |
| 1358 | Some(func_name.as_str()), |
| 1359 | host_module, |
| 1360 | alloc_return_funcs, |
| 1361 | optional_params, |
| 1362 | descriptor_params, |
| 1363 | internal_funcs, |
| 1364 | elemental_funcs, |
| 1365 | char_len_star_params, |
| 1366 | contained_host_refs, |
| 1367 | ambiguous_use_warnings, |
| 1368 | true, |
| 1369 | proc_scope_id, |
| 1370 | ); |
| 1371 | } |
| 1372 | } |
| 1373 | ProgramUnit::Module { |
| 1374 | decls, |
| 1375 | uses, |
| 1376 | contains, |
| 1377 | .. |
| 1378 | } => { |
| 1379 | // Module globals are installed in pass 1 (collect_module_globals). |
| 1380 | // The module body has no executable statements, but its CONTAINS |
| 1381 | // subprograms (module procedures) must be lowered as top-level |
| 1382 | // functions so they are emitted into the object file. |
| 1383 | let visible_param_consts = |
| 1384 | collect_decl_param_consts_with_host(decls, host_param_consts); |
| 1385 | let combined_uses: Vec<crate::ast::decl::SpannedDecl> = |
| 1386 | host_uses.iter().chain(uses.iter()).cloned().collect(); |
| 1387 | let module_name = match &unit.node { |
| 1388 | ProgramUnit::Module { name, .. } => Some(name.as_str()), |
| 1389 | _ => None, |
| 1390 | }; |
| 1391 | // Module procedures don't have host-local closure association; |
| 1392 | // they resolve module-level names through globals. Pass an |
| 1393 | // empty host_decls slice. |
| 1394 | let no_host_decls: Vec<crate::ast::decl::SpannedDecl> = Vec::new(); |
| 1395 | for sub in contains { |
| 1396 | let module_scope = module_name.and_then(|n| { |
| 1397 | st.all_scopes() |
| 1398 | .iter() |
| 1399 | .enumerate() |
| 1400 | .find_map(|(idx, scope)| match &scope.kind { |
| 1401 | crate::sema::symtab::ScopeKind::Module(scope_name) |
| 1402 | if scope_name.eq_ignore_ascii_case(n) => |
| 1403 | { |
| 1404 | Some(idx) |
| 1405 | } |
| 1406 | _ => None, |
| 1407 | }) |
| 1408 | }); |
| 1409 | lower_unit( |
| 1410 | module, |
| 1411 | sub, |
| 1412 | st, |
| 1413 | globals, |
| 1414 | type_layouts, |
| 1415 | &combined_uses, |
| 1416 | &visible_param_consts, |
| 1417 | &no_host_decls, |
| 1418 | None, |
| 1419 | module_name, |
| 1420 | alloc_return_funcs, |
| 1421 | optional_params, |
| 1422 | descriptor_params, |
| 1423 | internal_funcs, |
| 1424 | elemental_funcs, |
| 1425 | char_len_star_params, |
| 1426 | contained_host_refs, |
| 1427 | ambiguous_use_warnings, |
| 1428 | false, |
| 1429 | module_scope, |
| 1430 | ); |
| 1431 | } |
| 1432 | } |
| 1433 | ProgramUnit::Submodule { |
| 1434 | parent, |
| 1435 | name: submodule_name, |
| 1436 | decls, |
| 1437 | uses, |
| 1438 | contains, |
| 1439 | .. |
| 1440 | } => { |
| 1441 | // F2018 §11.2.3: a submodule provides implementations for the |
| 1442 | // separate-module procedures declared in its parent module's |
| 1443 | // interface block. The parent module already installed its |
| 1444 | // globals in pass 1; the submodule's own decls (if any) act |
| 1445 | // like additional private module-scope state. We treat the |
| 1446 | // submodule's CONTAINS subprograms exactly like the parent |
| 1447 | // module's contains — emit them as top-level functions whose |
| 1448 | // host scope is the parent module — so the linker sees the |
| 1449 | // implementations the program later calls into. |
| 1450 | // |
| 1451 | // Caveat: only separate-module-procedure bodies (those with |
| 1452 | // a `module` prefix or matching a parent interface) link as |
| 1453 | // `afs_modproc_<parent>_<name>`; plain contained helpers |
| 1454 | // (`pure function anycolor(...)` declared only inside the |
| 1455 | // submodule) live in the submodule's own scope, and the call |
| 1456 | // site resolves them through the `Submodule(name)` scope — |
| 1457 | // so their definition must use the submodule name to match. |
| 1458 | // Use the scope-aware folder so initializers like |
| 1459 | // `integer, parameter :: ilp = int64` (where int64 is |
| 1460 | // imported from another module) can resolve via the |
| 1461 | // symbol table; otherwise the param falls through to a |
| 1462 | // zero-initialized module global. |
| 1463 | let visible_param_consts = |
| 1464 | collect_decl_param_consts_with_scope(decls, host_param_consts, st); |
| 1465 | let combined_uses: Vec<crate::ast::decl::SpannedDecl> = |
| 1466 | host_uses.iter().chain(uses.iter()).cloned().collect(); |
| 1467 | let no_host_decls: Vec<crate::ast::decl::SpannedDecl> = Vec::new(); |
| 1468 | for sub in contains { |
| 1469 | let sub_is_smp_body = match &sub.node { |
| 1470 | ProgramUnit::Function { prefix, .. } |
| 1471 | | ProgramUnit::Subroutine { prefix, .. } => prefix |
| 1472 | .iter() |
| 1473 | .any(|p| matches!(p, crate::ast::unit::Prefix::Module)), |
| 1474 | _ => false, |
| 1475 | }; |
| 1476 | // SMP bodies link under the parent module's name (per |
| 1477 | // F2018 §11.2.3 — the implementation slot belongs to |
| 1478 | // the parent's interface). Plain helpers contained in |
| 1479 | // the submodule live in the submodule's own scope and |
| 1480 | // link there. host_module drives the IR procedure link |
| 1481 | // name AND the install_globals_as_locals lookup; for |
| 1482 | // SMP bodies these two needs diverge — link name needs |
| 1483 | // parent, but globals lookup also needs the containing |
| 1484 | // submodule (since commit d770b77 mangles |
| 1485 | // submodule-local globals under the submodule name). |
| 1486 | // Stash that submodule via the extra_host thread-local |
| 1487 | // so install_globals_as_locals_in can pick it up. |
| 1488 | let host_module_name = if sub_is_smp_body { |
| 1489 | parent.as_str() |
| 1490 | } else { |
| 1491 | submodule_name.as_str() |
| 1492 | }; |
| 1493 | let _smp_extra_host_guard = if sub_is_smp_body { |
| 1494 | Some(SmpExtraHostGuard::set(submodule_name.clone())) |
| 1495 | } else { |
| 1496 | None |
| 1497 | }; |
| 1498 | let submod_scope = st.all_scopes().iter().enumerate().find_map(|(idx, scope)| { |
| 1499 | match &scope.kind { |
| 1500 | crate::sema::symtab::ScopeKind::Submodule(scope_name) |
| 1501 | if scope_name.eq_ignore_ascii_case(submodule_name) => |
| 1502 | { |
| 1503 | Some(idx) |
| 1504 | } |
| 1505 | _ => None, |
| 1506 | } |
| 1507 | }); |
| 1508 | lower_unit( |
| 1509 | module, |
| 1510 | sub, |
| 1511 | st, |
| 1512 | globals, |
| 1513 | type_layouts, |
| 1514 | &combined_uses, |
| 1515 | &visible_param_consts, |
| 1516 | &no_host_decls, |
| 1517 | None, |
| 1518 | Some(host_module_name), |
| 1519 | alloc_return_funcs, |
| 1520 | optional_params, |
| 1521 | descriptor_params, |
| 1522 | internal_funcs, |
| 1523 | elemental_funcs, |
| 1524 | char_len_star_params, |
| 1525 | contained_host_refs, |
| 1526 | ambiguous_use_warnings, |
| 1527 | false, |
| 1528 | submod_scope, |
| 1529 | ); |
| 1530 | } |
| 1531 | } |
| 1532 | _ => {} |
| 1533 | } |
| 1534 | } |
| 1535 |