From 6237773b5855fef65c972421403f957f582e4195 Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Wed, 19 Jun 2024 11:22:29 +0200 Subject: [PATCH 1/7] init --- Cargo.lock | 13 + Cargo.toml | 4 + crates/haskell/Cargo.toml | 23 + crates/haskell/src/lib.rs | 1388 +++++++++++++++++++++++++++++++++++++ src/bin/wit-bindgen.rs | 11 + 5 files changed, 1439 insertions(+) create mode 100644 crates/haskell/Cargo.toml create mode 100644 crates/haskell/src/lib.rs diff --git a/Cargo.lock b/Cargo.lock index 2ae04279b..048b5a562 100644 --- a/Cargo.lock +++ b/Cargo.lock @@ -2365,6 +2365,7 @@ dependencies = [ "wit-bindgen-core", "wit-bindgen-csharp", "wit-bindgen-go", + "wit-bindgen-haskell", "wit-bindgen-markdown", "wit-bindgen-rust", "wit-bindgen-teavm-java", @@ -2409,6 +2410,18 @@ dependencies = [ "wit-bindgen-core", ] +[[package]] +name = "wit-bindgen-haskell" +version = "0.26.0" +dependencies = [ + "anyhow", + "clap", + "heck 0.5.0", + "indexmap", + "wit-bindgen-core", + "wit-parser 0.209.0", +] + [[package]] name = "wit-bindgen-markdown" version = "0.26.0" diff --git a/Cargo.toml b/Cargo.toml index a53c5af83..7514c94a2 100644 --- a/Cargo.toml +++ b/Cargo.toml @@ -43,6 +43,7 @@ wit-bindgen-teavm-java = { path = 'crates/teavm-java', version = '0.26.0' } wit-bindgen-go = { path = 'crates/go', version = '0.26.0' } wit-bindgen-csharp = { path = 'crates/csharp', version = '0.26.0' } wit-bindgen-markdown = { path = 'crates/markdown', version = '0.26.0' } +wit-bindgen-haskell = { path = 'crates/haskell', version = '0.26.0' } wit-bindgen = { path = 'crates/guest-rust', version = '0.26.0', default-features = false } [[bin]] @@ -58,6 +59,7 @@ wit-bindgen-markdown = { workspace = true, features = ['clap'], optional = true wit-bindgen-teavm-java = { workspace = true, features = ['clap'], optional = true } wit-bindgen-go = { workspace = true, features = ['clap'], optional = true } wit-bindgen-csharp = { workspace = true, features = ['clap'], optional = true } +wit-bindgen-haskell = { workspace = true, features = ['clap'], optional = true} wit-component = { workspace = true } wasm-encoder = { workspace = true } @@ -69,6 +71,7 @@ default = [ 'teavm-java', 'go', 'csharp-naot', + 'haskell', ] c = ['dep:wit-bindgen-c'] rust = ['dep:wit-bindgen-rust'] @@ -78,6 +81,7 @@ go = ['dep:wit-bindgen-go'] csharp = ['dep:wit-bindgen-csharp'] csharp-naot = ['csharp'] csharp-mono = ['csharp'] +haskell = ['dep:wit-bindgen-haskell'] [dev-dependencies] heck = { workspace = true } diff --git a/crates/haskell/Cargo.toml b/crates/haskell/Cargo.toml new file mode 100644 index 000000000..2dae3bead --- /dev/null +++ b/crates/haskell/Cargo.toml @@ -0,0 +1,23 @@ +[package] +name = "wit-bindgen-haskell" +version.workspace = true +edition.workspace = true +repository = 'https://github.com/bytecodealliance/wit-bindgen' +license = "Apache-2.0 WITH LLVM-exception" +homepage = 'https://github.com/bytecodealliance/wit-bindgen' +description = """ +Haskell bindings generator for WIT and the component model, typically used +through the `wit-bindgen-cli` crate. +""" + +[lib] +test = false +doctest = false + +[dependencies] +wit-bindgen-core = { workspace = true } +wit-parser = { workspace = true } +anyhow = { workspace = true } +heck = { workspace = true } +clap = { workspace = true, optional = true } +indexmap = { workspace = true } diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs new file mode 100644 index 000000000..ebfd0dd52 --- /dev/null +++ b/crates/haskell/src/lib.rs @@ -0,0 +1,1388 @@ +use abi::{AbiVariant, WasmType}; +use anyhow::Result; +use heck::{ToLowerCamelCase as _, ToUpperCamelCase as _}; +use indexmap::{IndexMap, IndexSet}; +use wit_bindgen_core; +use wit_bindgen_core::abi::{call, Bindgen, Bitcast, Instruction, LiftLower}; +use wit_bindgen_core::{Direction, Files, Source, WorldGenerator}; + +use wit_parser::*; + +#[derive(Default, Debug, Clone)] +#[cfg_attr(feature = "clap", derive(clap::Args))] +pub struct Opts {} + +impl Opts { + pub fn build(&self) -> Box { + let mut r = Haskell::default(); + r.opts = self.clone(); + Box::new(r) + } +} + +#[derive(Default)] +pub struct Module { + funcs: Source, + tydefs: IndexSet, + docs: Option, + imports_exports: bool, +} + +#[derive(Default)] +pub struct Haskell { + modules: IndexMap, + opts: Opts, +} + +impl WorldGenerator for Haskell { + fn import_interface( + &mut self, + resolve: &Resolve, + name: &WorldKey, + iface: InterfaceId, + _files: &mut Files, + ) -> Result<()> { + let iface = &resolve.interfaces[iface]; + let iname = if let WorldKey::Name(name) = name { + name.clone() + } else { + iface.name.clone().unwrap() + }; + let iname = upper_ident(None, &iname); + let module = if let Some(module) = self.modules.get_mut(&iname) { + module + } else { + self.modules.insert(iname.clone(), Default::default()); + self.modules.get_mut(&iname).unwrap() + }; + module.docs = iface.docs.contents.clone(); + for (name, ty) in &iface.types { + module.tydefs.insert(gen_typedef(resolve, name, *ty)); + } + for (name, func) in &iface.functions { + module.funcs.push_str(&gen_func_core( + resolve, + func, + iface.name.as_deref(), + AbiVariant::GuestImport, + )); + module.funcs.push_str("\n"); + module + .funcs + .push_str(&gen_func(resolve, &func, iface.name.as_deref())); + } + Ok(()) + } + + fn export_interface( + &mut self, + resolve: &Resolve, + name: &WorldKey, + iface: InterfaceId, + _files: &mut Files, + ) -> Result<()> { + let iface = &resolve.interfaces[iface]; + let iname = if let WorldKey::Name(name) = name { + name.clone() + } else { + iface.name.clone().unwrap() + }; + let iname = upper_ident(None, &iname); + let module = if let Some(module) = self.modules.get_mut(&iname) { + module + } else { + self.modules.insert(iname.clone(), Default::default()); + self.modules.get_mut(&iname).unwrap() + }; + module.docs = iface.docs.contents.clone(); + for (name, ty) in &iface.types { + module.tydefs.insert(gen_typedef(resolve, name, *ty)); + } + if !iface.functions.is_empty() { + module.imports_exports = true; + } + for (name, func) in &iface.functions { + module.funcs.push_str("\n"); + module.funcs.push_str(&gen_func_core( + resolve, + func, + iface.name.as_deref(), + AbiVariant::GuestExport, + )); + } + + Ok(()) + } + + fn import_funcs( + &mut self, + resolve: &Resolve, + world: WorldId, + funcs: &[(&str, &Function)], + _files: &mut Files, + ) { + let world = &resolve.worlds[world]; + let world_name = upper_ident(None, &world.name); + let module = if let Some(module) = self.modules.get_mut(&world_name) { + module + } else { + self.modules.insert(world_name.clone(), Default::default()); + self.modules.get_mut(&world_name).unwrap() + }; + module.docs = world.docs.contents.clone(); + for (name, func) in funcs { + module + .funcs + .push_str(&gen_func_core(resolve, func, None, AbiVariant::GuestImport)); + module.funcs.push_str("\n"); + module + .funcs + .push_str(&gen_func(resolve, func, Some(&world_name))); + module.funcs.push_str("\n"); + } + } + + fn export_funcs( + &mut self, + resolve: &Resolve, + world: WorldId, + funcs: &[(&str, &Function)], + _files: &mut Files, + ) -> Result<()> { + let world = &resolve.worlds[world]; + let world_name = upper_ident(None, &world.name); + let module = if let Some(module) = self.modules.get_mut(&world_name) { + module + } else { + self.modules.insert(world_name.clone(), Default::default()); + self.modules.get_mut(&world_name).unwrap() + }; + if !funcs.is_empty() { + module.imports_exports = true; + } + module.docs = world.docs.contents.clone(); + for (name, func) in funcs { + module + .funcs + .push_str(&gen_func_core(resolve, func, None, AbiVariant::GuestExport)); + module.funcs.push_str("\n"); + } + Ok(()) + } + + fn import_types( + &mut self, + resolve: &Resolve, + world: WorldId, + types: &[(&str, TypeId)], + _files: &mut Files, + ) { + let world = &resolve.worlds[world]; + let world_name: String = upper_ident(None, &world.name); + let module = if let Some(module) = self.modules.get_mut(&world_name) { + module + } else { + self.modules.insert(world_name.clone(), Default::default()); + self.modules.get_mut(&world_name).unwrap() + }; + module.docs = world.docs.contents.clone(); + module.tydefs.insert( + types + .iter() + .map(|(name, id)| gen_typedef(resolve, name, *id)) + .collect::>() + .join("\n"), + ); + } + + fn finish(&mut self, _resolve: &Resolve, _world: WorldId, files: &mut Files) -> Result<()> { + for (name, module) in self.modules.iter_mut() { + let contents = gen_module( + name, + &module.funcs, + module.imports_exports, + !module.tydefs.is_empty(), + &module.docs, + ); + files.push(&format!("{name}.hs"), &contents); + if module.tydefs.is_empty() { + continue; + } + let contents = gen_module( + &format!("Types.{name}"), + &module + .tydefs + .iter() + .map(|m| m.clone()) + .collect::>() + .join("\n"), + false, + false, + &module.docs, + ); + files.push(&format!("Types.{name}.hs"), &contents); + } + Ok(()) + } +} + +fn gen_module( + name: &str, + src: &str, + imports_exports: bool, + import_types: bool, + docs: &Option, +) -> Vec { + format!( + "\ +-- Generated by wit-bindgen. + +{} +module {name} where + +import Data.Word; +import Data.Int; +import Data.Bits; +import Data.Text; +import Data.Text.Encoding; +import Data.ByteString; +import GHC.Float; +import Foreign.Ptr; +import Foreign.Storable; +import Foreign.Marshal.Array; + +{} +{} +{} +", + if let Some(docs) = docs { + docs.lines() + .map(|line| format!("-- {line}\n")) + .collect::() + } else { + "".to_owned() + }, + if import_types { + format!("\nimport Types.{name};\n") + } else { + "".to_owned() + }, + if imports_exports { + format!("\nimport qualified Exports.{name};\n") + } else { + "".to_owned() + }, + src.to_string() + ) + .as_bytes() + .to_owned() +} + +struct HsFunc<'a> { + ns: Option<&'a str>, + dual_func: String, + params: Vec, + blocks: Vec, + var_count: usize, + size_align: SizeAlign, + variant: AbiVariant, +} + +fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { + let mut src = String::new(); + let ty = &resolve.types[id]; + if let Some(docs) = &ty.docs.contents { + src.push_str("\n"); + src.push_str( + &docs + .lines() + .map(|line| format!("-- {line}\n")) + .collect::(), + ); + } + match &ty.kind { + TypeDefKind::Record(record) => { + let record_name = upper_ident(None, name); + src.push_str(&format!( + "data {record_name} = {record_name} {{ {} }};\n", + record + .fields + .iter() + .map(|field| { + format!( + "{} :: {}", + lower_ident(None, &[name, &field.name].join("-")), + ty_name(resolve, false, &field.ty) + ) + }) + .collect::>() + .join(", ") + )); + } + TypeDefKind::Resource => { + let resource_name = upper_ident(None, name); + src.push_str(&format!( + "newtype {resource_name} = {resource_name} Word32;\n" + )); + } + TypeDefKind::Handle(_) => todo!(), + TypeDefKind::Flags(flags) => { + let flags_name = upper_ident(None, name); + src.push_str(&format!( + "data {flags_name} = {flags_name} {{ {} }};\n", + flags + .flags + .iter() + .map(|flag| format!( + "{} :: Bool", + lower_ident(None, &[name, &flag.name].join("-")) + )) + .collect::>() + .join(", ") + )); + } + TypeDefKind::Tuple(_) => todo!(), + TypeDefKind::Variant(var) => { + let cases = var + .cases + .iter() + .map(|case| { + format!( + "{} {}", + upper_ident(None, &[name, &case.name].join("-")), + if let Some(ty) = case.ty { + ty_name(resolve, false, &ty) + } else { + "".to_owned() + } + ) + }) + .collect::>() + .join(" | "); + src.push_str(&format!("data {} = {cases};\n", upper_ident(None, name))) + } + TypeDefKind::Enum(enu) => { + let cases = enu + .cases + .iter() + .map(|case| upper_ident(None, &[name, &case.name].join("-"))) + .collect::>() + .join(" | "); + src.push_str(&format!("data {} = {cases};\n", upper_ident(None, name))) + } + TypeDefKind::Option(ty) => todo!(), + TypeDefKind::Result(_) => todo!(), + TypeDefKind::List(_) => todo!(), + TypeDefKind::Future(_) => todo!(), + TypeDefKind::Stream(_) => todo!(), + TypeDefKind::Type(ty) => { + src.push_str(&format!( + "type {} = {};\n", + upper_ident(None, name), + ty_name(resolve, false, ty) + )); + } + TypeDefKind::Unknown => todo!(), + } + src +} + +impl<'a> Bindgen for HsFunc<'a> { + type Operand = String; + + fn emit( + &mut self, + resolve: &Resolve, + inst: &Instruction<'_>, + operands: &mut Vec, + results: &mut Vec, + ) { + match inst { + Instruction::GetArg { nth } => results.push(self.params[*nth].clone()), + Instruction::I32Const { val } => results.push(val.to_string()), + Instruction::Bitcasts { casts } => results.extend( + operands + .iter() + .zip(casts.iter()) + .map(|(op, cast)| bitcast(op, cast)) + .collect::>(), + ), + Instruction::ConstZero { tys } => results.extend(tys.iter().map(|ty| { + match ty { + WasmType::I32 => "(0 :: Word32)", + WasmType::I64 => "(0 :: Word64)", + WasmType::F32 => "(0.0 :: Float)", + WasmType::F64 => "(0.0 :: Double)", + WasmType::Pointer => "(0 :: Word32)", + WasmType::PointerOrI64 => "(0 :: Word64)", + WasmType::Length => "(0 :: Word32)", + } + .to_owned() + })), + Instruction::I32Load { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::I32Load8U { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word8 -> IO Word8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!( + "((fromIntegral :: Word8 -> Word32) bg_v{})", + self.var_count + )); + self.var_count += 1; + } + Instruction::I32Load8S { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Int8 -> IO Int8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!( + "((fromIntegral :: Int8 -> Word32) bg_v{})", + self.var_count + )); + self.var_count += 1; + } + Instruction::I32Load16U { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word16 -> IO Word16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!( + "((fromIntegral :: Word16 -> Word32) bg_v{})", + self.var_count + )); + self.var_count += 1; + } + Instruction::I32Load16S { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Int16 -> IO Int16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!( + "((fromIntegral :: Int16 -> Word32) bg_v{})", + self.var_count + )); + self.var_count += 1; + } + Instruction::I64Load { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word64 -> IO Word64) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::F32Load { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Float -> IO Float) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::F64Load { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Double -> IO Double) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::PointerLoad { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::LengthLoad { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::I32Store { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[0], operands[1] + )); + } + Instruction::I32Store8 { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word8 -> Word8 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word8) {});\n", + operands[0], operands[1] + )); + } + Instruction::I32Store16 { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word16 -> Word16 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word16) {});\n", + operands[0], operands[1] + )); + } + Instruction::I64Store { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word64 -> Word64 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[0], operands[1] + )); + } + Instruction::F32Store { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Float -> Float -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[0], operands[1] + )); + } + Instruction::F64Store { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Double -> Double -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[0], operands[1] + )); + } + Instruction::PointerStore { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[0], operands[1] + )); + } + Instruction::LengthStore { offset } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word32) {});\n", + operands[0], operands[1] + )); + } + Instruction::I32FromChar => results.push(format!( + "((fromIntegral :: Int -> Word32) (ord {}))", + operands[0] + )), + Instruction::I64FromU64 => results.push(operands[0].clone()), + Instruction::I64FromS64 => results.push(format!( + "((fromIntegral :: Int64 -> Word64) {})", + operands[0] + )), + Instruction::I32FromU32 => results.push(format!( + "((fromIntegral :: Word32 -> Word64) {})", + operands[0] + )), + Instruction::I32FromS32 => results.push(format!( + "((fromIntegral :: Int32 -> Word32) {})", + operands[0] + )), + Instruction::I32FromU16 => results.push(format!( + "((fromIntegral :: Word16 -> Word32) {})", + operands[0] + )), + Instruction::I32FromS16 => results.push(format!( + "((fromIntegral :: Int16 -> Word32) {})", + operands[0] + )), + Instruction::I32FromU8 => results.push(format!( + "((fromIntegral :: Word8 -> Word32) {})", + operands[0] + )), + Instruction::I32FromS8 => results.push(format!( + "((fromIntegral :: Int8 -> Word32) {})", + operands[0] + )), + Instruction::CoreF32FromF32 | Instruction::CoreF64FromF64 => { + results.push(operands[0].clone()) + } + Instruction::S8FromI32 => results.push(format!( + "((fromIntegral :: Word32 -> Int8) {})", + operands[0] + )), + Instruction::U8FromI32 => results.push(format!( + "((fromIntegral :: Word32 -> Word8) {})", + operands[0] + )), + Instruction::S16FromI32 => results.push(format!( + "((fromIntegral :: Word32 -> Int16) {})", + operands[0] + )), + Instruction::U16FromI32 => results.push(format!( + "((fromIntegral :: Word32 -> Word16) {})", + operands[0] + )), + Instruction::S32FromI32 => results.push(format!( + "((fromIntegral :: Word32 -> Int32) {})", + operands[0] + )), + Instruction::U32FromI32 => results.push(operands[0].clone()), + Instruction::S64FromI64 => results.push(format!( + "((fromIntegral :: Word64 -> Int64) {})", + operands[0] + )), + Instruction::U64FromI64 => results.push(operands[0].clone()), + Instruction::CharFromI32 => results.push(format!("(chr {})", operands[0])), + Instruction::F32FromCoreF32 | Instruction::F64FromCoreF64 => { + results.push(operands[0].clone()) + } + Instruction::BoolFromI32 => results.push(format!("({} /= 0)", operands[0])), + Instruction::I32FromBool => results.push(format!( + "(if {} then (1 :: Word32) else (0 :: Word32))", + operands[0] + )), + Instruction::ListCanonLower { element, realloc } => { + let list = operands[0].clone(); + let ptr: String = format!("bg_v{}", self.var_count); + let len = format!("bg_v{}", self.var_count + 1); + self.var_count += 2; + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("{len} <- length {list};\n")); + self.blocks.last_mut().unwrap().push_str(&format!( + "{ptr} <- (callocBytes :: Int -> IO (Ptr [{}])) {len};\n", + ty_name(resolve, false, element) + )); + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("pokeArray {ptr} {list};\n",)); + results.extend([ptr, len]); + } + Instruction::StringLower { realloc } => { + let ptr: String = format!("bg_v{}", self.var_count); + let len = format!("bg_v{}", self.var_count + 1); + self.var_count += 2; + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("bg_tmp <- unpack (encodeUtf8 {});\n", operands[0])); + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("{len} <- length bg_tmp;\n")); + self.blocks.last_mut().unwrap().push_str(&format!( + "{ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) {len};\n" + )); + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("pokeArray {ptr} bg_tmp;\n")); + results.extend([ptr, len]); + } + Instruction::ListLower { element, realloc } => { + let size = self.size_align.size(element); + let list = operands[0].clone(); + let block = self.blocks.pop().unwrap(); + let list_len = format!("bg_v{}", self.var_count + 1); + let list_ptr = format!("bg_v{}", self.var_count); + self.var_count += 2; + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("{list_len} <- length {list};\n",)); + self.blocks.last_mut().unwrap().push_str(&format!( + "{list_ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) ({list_len} * {});\n", + size + )); + self.blocks.last_mut().unwrap().push_str(&format!( + "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}\n}}) (zip (enumFromThenTo {list_ptr} ({list_ptr} + {size}) ({list_len} * {size} - {size})) {list});\n", + block.to_string() + )); + results.extend([list_ptr, list_len]); + } + Instruction::ListCanonLift { element, ty } => { + let ty = ty_name(resolve, false, element); + let ptr = operands[0].clone(); + let len = operands[1].clone(); + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) {len} (wordPtrToPtr {ptr}));\n", + self.var_count + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::StringLift => { + let ptr = operands[0].clone(); + let len = operands[1].clone(); + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("bg_v{} <- return (decodeUtf8 ((pack :: [Word8] -> ByteString) ((peekArray :: Int -> Ptr Word8 -> IO [Word8]) {len} (wordPtrToPtr {ptr}))));\n", self.var_count)); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::ListLift { element, ty } => { + let size = self.size_align.size(element); + let ptr = operands[0].clone(); + let len = operands[1].clone(); + let block = self.blocks.pop().unwrap(); + self.blocks + .last_mut() + .unwrap() + .push_str(&format!( + "bg_v{} <- mapM (\\bg_base_ptr -> do {{\n{};\nreturn bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", + self.var_count, + block.to_string() + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::IterElem { element } => { + results.push("bg_elem".to_owned()); + } + Instruction::IterBasePointer => { + results.push("bg_base_ptr".to_owned()); + } + Instruction::RecordLower { record, name, ty } => { + results.extend(record.fields.iter().map(|field| { + format!( + "({} {})", + lower_ident(self.ns, &format!("{name}-{}", field.name)), + operands[0] + ) + })); + } + Instruction::RecordLift { record, name, ty } => { + let fields = record + .fields + .iter() + .zip(operands) + .map(|(field, op)| { + format!( + "{} = {op}", + lower_ident(self.ns, &format!("{name}-{}", field.name)) + ) + }) + .collect::>() + .join(", "); + results.push(format!("{{ {} }}", fields)); + } + Instruction::HandleLower { handle, name, ty } => todo!(), + Instruction::HandleLift { handle, name, ty } => todo!(), + Instruction::TupleLower { tuple, ty } => { + let fields = tuple + .types + .iter() + .enumerate() + .map(|(i, _)| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- return ({});\n", + fields.join(", "), + operands[0] + )); + self.var_count += fields.len(); + results.extend(fields); + } + Instruction::TupleLift { tuple, ty } => { + results.push(format!("({})", operands.join(", "))); + } + Instruction::FlagsLower { flags, name, ty } => todo!(), + Instruction::FlagsLift { flags, name, ty } => { + results.push(format!( + "({} {{ {} }})", + upper_ident(None, name), + flags + .flags + .iter() + .enumerate() + .map(|(i, flag)| { + format!( + "{} = ((shiftR {} {i}) (.&.) 1) == 1)", + flag.name, + operands[0 / 32] + ) + }) + .collect::>() + .join(", ") + )); + } + Instruction::VariantPayloadName => { + results.push("bg_payload".to_owned()); + } + Instruction::VariantLower { + variant, + name, + ty, + results: types, + } => { + let blocks = self.blocks.drain(self.blocks.len() - variant.cases.len()..); + let cases = variant + .cases + .iter() + .zip(blocks) + .map(|(case, block)| { + format!( + "{}{}{} -> do {{\n{}; return bg_v }}", + upper_ident(None, name), + upper_ident(None, &case.name), + if case.ty.is_some() { " bg_payload" } else { "" }, + block.to_string() + ) + }) + .collect::>() + .join(";\n"); + let vars = types + .iter() + .enumerate() + .map(|(i, _)| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- (case {} of {{\n{cases} }});\n", + vars.join(", "), + operands[0] + )); + results.extend(vars); + self.var_count += types.len(); + } + Instruction::VariantLift { variant, name, ty } => { + let blocks = self.blocks.drain(self.blocks.len() - variant.cases.len()..); + let cases = variant + .cases + .iter() + .enumerate() + .zip(blocks) + .map(|((i, case), block)| { + format!( + "{i} -> do {{ {};\n(return ({}{} bg_v))\n}}\n", + block.to_string(), + ty_name(resolve, false, &Type::Id(*ty)), + upper_ident(None, &case.name), + ) + }) + .collect::>() + .join(";\n"); + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (case {} of {{\n{cases} }})", + self.var_count, operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::EnumLower { enum_, name, ty } => { + let arms = enum_ + .cases + .iter() + .enumerate() + .map(|(i, case)| { + format!( + "{}{} -> {i}", + ty_name(resolve, false, &Type::Id(*ty)), + upper_ident(None, &format!("{}", case.name)) + ) + }) + .collect::>() + .join(";\n"); + results.push(format!("(case {} of {{\n{arms} }})", operands[0])); + } + Instruction::EnumLift { enum_, name, ty } => { + let arms = enum_ + .cases + .iter() + .enumerate() + .map(|(i, case)| { + format!( + "{i} -> {}{}", + ty_name(resolve, false, &Type::Id(*ty)), + upper_ident(None, &case.name) + ) + }) + .collect::>() + .join(";\n"); + results.push(format!( + "(case {} of {{\n{arms};\n_ -> error \"\" }})", + operands[0] + )); + } + Instruction::OptionLower { + payload, + ty, + results: types, + } => { + let some = self.blocks.pop().unwrap().to_string(); + let none = self.blocks.pop().unwrap().to_string(); + let vars = types + .iter() + .enumerate() + .map(|(i, _)| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.var_count += vars.len(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- case {} of {{\nNothing -> do {{\n{none}\n}};\nJust bg_payload -> do {{\n{some}\n}} }}\n", + vars.join(", "), + operands[0] + )); + results.extend(vars); + } + Instruction::OptionLift { payload, ty } => { + let some = self.blocks.pop().unwrap().to_string(); + let none = self.blocks.pop().unwrap().to_string(); + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (case {} of\n0 -> (do {{\n{none};\nreturn Nothing\n}});\n1 -> (do {{\n{some});\nreturn (Just bg_v)\n}})))", + self.var_count, + operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::ResultLower { + result, + ty, + results: types, + } => { + let ok = self.blocks.pop().unwrap().to_string(); + let err = self.blocks.pop().unwrap().to_string(); + let vars = types + .iter() + .enumerate() + .map(|(i, _)| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.var_count += vars.len(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}\n}};\nRight bg_payload -> do {{\n{ok}\n}} }}\n", + vars.join(", "), + operands[0] + )); + results.extend(vars); + } + Instruction::ResultLift { result, ty } => { + let err = self.blocks.pop().unwrap().to_string(); + let ok = self.blocks.pop().unwrap().to_string(); + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_v{} <- (case {} of\n0 -> (do {{\n{err};\nreturn (Left bg_v)\n}});\n1 -> (do {{\n{ok});\nreturn (Right bg_v)\n}})))", + self.var_count, + operands[0] + )); + results.push(format!("bg_v{}", self.var_count)); + self.var_count += 1; + } + Instruction::CallWasm { name, sig } => { + let vars = sig + .results + .iter() + .enumerate() + .map(|(i, _result)| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- ({} {});\n", + vars.join(", "), + self.dual_func, + operands.join(" ") + )); + results.extend(vars); + self.var_count += sig.results.len(); + } + Instruction::CallInterface { func } => { + let vars = (0..func.results.len()) + .map(|i| format!("bg_v{}", self.var_count + i)) + .collect::>(); + self.var_count += vars.len(); + self.blocks.last_mut().unwrap().push_str(&format!( + "({}) <- ({} {});\n", + vars.join(", "), + self.dual_func, + operands.join(" ") + )); + results.extend(vars); + } + Instruction::Return { amt, func } => { + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("return ({})", operands.join(", "))); + } + Instruction::Malloc { + realloc, + size, + align, + } => todo!(), + Instruction::GuestDeallocate { size, align } => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {}));\n", + operands[0] + )); + } + Instruction::GuestDeallocateString => todo!(), + Instruction::GuestDeallocateList { element } => todo!(), + Instruction::GuestDeallocateVariant { blocks } => todo!(), + } + } + + fn return_pointer(&mut self, size: usize, align: usize) -> Self::Operand { + self.blocks.last_mut().unwrap().push_str(&format!( + "bg_ret_ptr <- (callocBytes :: Int -> IO (Ptr Word8)) {size};\n" + )); + "bg_ret_ptr".to_owned() + } + + fn push_block(&mut self) { + self.blocks.push(Source::default()); + } + + fn finish_block(&mut self, operand: &mut Vec) { + self.blocks + .last_mut() + .unwrap() + .push_str(&format!("bg_v <- return ({})", operand.join(", "))); + } + + fn sizes(&self) -> &SizeAlign { + &self.size_align + } + + fn is_list_canonical(&self, _resolve: &Resolve, element: &Type) -> bool { + match element { + Type::Bool + | Type::U8 + | Type::U16 + | Type::U32 + | Type::U64 + | Type::S8 + | Type::S16 + | Type::S32 + | Type::S64 + | Type::F32 + | Type::F64 + | Type::Char => true, + Type::String | Type::Id(_) => false, + } + } +} + +fn bitcast(op: &String, cast: &Bitcast) -> String { + match cast { + Bitcast::F32ToI32 => format!("(castFloatToWord32 {op})"), + Bitcast::F64ToI64 => format!("(castDoubleToWord64 {op})"), + Bitcast::I32ToI64 => format!("((fromIntegral :: Word32 -> Word64) {op})"), + Bitcast::F32ToI64 => { + format!("((fromIntegral :: Word32 -> Word64) (castFloatToWord32) {op})") + } + Bitcast::I32ToF32 => format!("(castWord32ToFloat {op})"), + Bitcast::I64ToF64 => format!("(castWord64ToDouble {op})"), + Bitcast::I64ToI32 => format!("((fromIntegral :: Word64 -> Word32) {op})"), + Bitcast::I64ToF32 => { + format!("(castWord32ToFloat ((fromIntegral :: Word64 -> Word32) {op}))") + } + Bitcast::P64ToI64 => format!("((fromIntegral :: Word64 -> Word64) {op})"), + Bitcast::I64ToP64 => op.clone(), + Bitcast::P64ToP => format!("((fromIntegral :: Word64 -> Word32) {op})"), + Bitcast::PToP64 => format!("((fromIntegral :: Word32 -> Word64) {op})"), + Bitcast::I32ToP => op.clone(), + Bitcast::PToI32 => op.clone(), + Bitcast::PToL => op.clone(), + Bitcast::LToP => op.clone(), + Bitcast::I32ToL => op.clone(), + Bitcast::LToI32 => op.clone(), + Bitcast::I64ToL => format!("((fromIntegral :: Word64 -> Word32) {op})"), + Bitcast::LToI64 => format!("((fromIntegral :: Word32 -> Word64) {op})"), + Bitcast::Sequence(seq) => { + let [first, second] = &**seq; + bitcast(&bitcast(op, first), second) + } + Bitcast::None => op.clone(), + } +} + +fn gen_func(resolve: &Resolve, func: &Function, ns: Option<&str>) -> String { + let mut src = String::new(); + if let Some(docs) = &func.docs.contents { + src.push_str("\n"); + src.push_str( + &docs + .lines() + .map(|line| format!("-- {line}\n")) + .collect::(), + ); + } + src.push_str(&format!("{} :: ", func_name(func, None))); + src.push_str( + &func + .params + .iter() + .map(|(_name, ty)| format!("{} ->", ty_name(resolve, false, ty))) + .collect::>() + .join(" "), + ); + src.push_str(" IO "); + match &func.results { + Results::Named(results) => { + src.push_str(&format!( + "({})", + results + .iter() + .map(|(_name, ty)| ty_name(resolve, false, ty)) + .collect::>() + .join(", ") + )); + } + Results::Anon(ty) => { + let mut name = ty_name(resolve, false, &ty); + if name.contains(" ") && !name.starts_with("(") && !name.starts_with("[") { + name = format!("({name})"); + } + src.push_str(&name); + } + } + let mut size_align = SizeAlign::new(AddressSize::Wasm32); + size_align.fill(resolve); + let mut bindgen = HsFunc { + ns: None, + dual_func: func_name_foreign(func, ns, Direction::Import), + params: func + .params + .iter() + .map(|(name, _ty)| lower_ident(None, &name)) + .collect(), + blocks: vec![Source::default()], + var_count: 0, + size_align, + variant: AbiVariant::GuestImport, + }; + src.push('\n'); + src.push_str(&format!( + "{} {} = ", + func_name(func, None), + bindgen.params.join(" ") + )); + call( + resolve, + AbiVariant::GuestImport, + LiftLower::LowerArgsLiftResults, + func, + &mut bindgen, + ); + src.push_str(&format!("do {{\n{}\n}};\n", &bindgen.blocks[0].to_string())); + + src.push('\n'); + src +} + +fn gen_func_core( + resolve: &Resolve, + func: &Function, + ns: Option<&str>, + variant: AbiVariant, +) -> String { + let mut src = String::new(); + let sig = resolve.wasm_signature(variant, func); + src.push_str(&format!( + "foreign {} ccall \"{}\" {} :: ", + if variant == AbiVariant::GuestExport { + "export" + } else { + "import" + }, + func.core_export_name(ns), + func_name_foreign( + func, + ns, + if variant == AbiVariant::GuestExport { + Direction::Export + } else { + Direction::Import + } + ), + )); + src.push_str( + &sig.params + .iter() + .map(|ty| format!("{} -> ", core_ty_name(*ty))) + .collect::>() + .join(""), + ); + let results = if sig.results.len() == 1 { + format!("IO {}", core_ty_name(sig.results[0])) + } else { + format!( + "IO ({})", + sig.results + .iter() + .map(|ty| core_ty_name(*ty)) + .collect::>() + .join(", ") + ) + }; + src.push_str(&results); + if variant == AbiVariant::GuestExport { + let mut size_align = SizeAlign::new(AddressSize::Wasm32); + size_align.fill(resolve); + let mut bindgen = HsFunc { + ns: None, + dual_func: func_name(func, ns), + params: sig + .params + .iter() + .enumerate() + .map(|(i, _)| format!("bg_p{i}")) + .collect(), + blocks: vec![Source::default()], + var_count: 0, + size_align, + variant, + }; + src.push('\n'); + src.push_str(&format!( + "{} {} = ", + func_name_foreign(func, ns, Direction::Export), + bindgen.params.join(" ") + )); + call( + resolve, + AbiVariant::GuestExport, + LiftLower::LiftArgsLowerResults, + func, + &mut bindgen, + ); + src.push_str(&format!("do {{\n{}\n}};\n", &bindgen.blocks[0].to_string())); + } + src.push('\n'); + src +} + +fn func_name_foreign(func: &Function, ns: Option<&str>, dir: Direction) -> String { + format!( + "bg_fn_{}_{}", + if dir == Direction::Import { + "imp" + } else { + "exp" + }, + lower_ident(ns, &func.core_export_name(None)) + .replace(|c: char| !c.is_ascii_alphanumeric(), "_") + ) +} + +fn func_name(func: &Function, ns: Option<&str>) -> String { + if let Some(ns) = ns { + format!("Exports.{}", lower_ident(Some(ns), &func.name)) + } else { + lower_ident(None, &func.name) + } +} + +fn lower_ident(ns: Option<&str>, name: &str) -> String { + format!( + "{}{}", + if let Some(ns) = ns { + format!("{}.", upper_ident(None, &ns)) + } else { + "".to_owned() + }, + name.to_lower_camel_case() + ) +} + +fn upper_ident(ns: Option<&str>, name: &str) -> String { + format!( + "{}{}", + if let Some(ns) = ns { + format!("{}.", ns.to_upper_camel_case()) + } else { + "".to_owned() + }, + name.to_upper_camel_case() + ) +} + +fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { + match ty { + Type::Bool => "Bool".to_owned(), + Type::U8 => "Word8".to_owned(), + Type::U16 => "Word16".to_owned(), + Type::U32 => "Word32".to_owned(), + Type::U64 => "Word64".to_owned(), + Type::S8 => "Int8".to_owned(), + Type::S16 => "Int16".to_owned(), + Type::S32 => "Int32".to_owned(), + Type::S64 => "Int64".to_owned(), + Type::F32 => "Float".to_owned(), + Type::F64 => "Double".to_owned(), + Type::Char => "Char".to_owned(), + Type::String => "Text".to_owned(), + Type::Id(id) => { + let ty = &resolve.types[*id]; + let ns: Option = if with_ns { + match ty.owner { + TypeOwner::World(id) => Some(resolve.worlds[id].name.clone()), + TypeOwner::Interface(id) => { + if let Some(name) = resolve.interfaces[id].name.clone() { + Some(name) + } else { + None + } + } + TypeOwner::None => None, + } + } else { + None + }; + let ns = ns.map(|n| format!("Types.{}", upper_ident(None, &n))); + if let Some(name) = &ty.name { + if let Some(ns) = ns { + format!("{ns}.{}", upper_ident(None, name)) + } else { + upper_ident(ns.as_deref(), name) + } + } else { + match &ty.kind { + TypeDefKind::Record(_) => todo!(), + TypeDefKind::Resource => todo!(), + TypeDefKind::Handle(_) => todo!(), + TypeDefKind::Flags(_) => todo!(), + TypeDefKind::Tuple(tuple) => { + format!( + "({})", + tuple + .types + .iter() + .map(|ty| { ty_name(resolve, with_ns, ty) }) + .collect::>() + .join(", ") + ) + } + TypeDefKind::Variant(_) => todo!(), + TypeDefKind::Enum(_) => todo!(), + TypeDefKind::Option(ty) => { + format!("Maybe {}", ty_name(resolve, with_ns, ty)) + } + TypeDefKind::Result(result) => { + let ok_ty = if let Some(ty) = result.ok { + ty_name(resolve, with_ns, &ty) + } else { + "()".to_owned() + }; + let err_ty = if let Some(ty) = result.err { + ty_name(resolve, with_ns, &ty) + } else { + "()".to_owned() + }; + format!("Either {err_ty} {ok_ty}") + } + TypeDefKind::List(ty) => { + format!("[{}]", ty_name(resolve, with_ns, ty)) + } + TypeDefKind::Future(_) => todo!(), + TypeDefKind::Stream(_) => todo!(), + TypeDefKind::Type(ty) => ty_name(resolve, with_ns, ty), + TypeDefKind::Unknown => todo!(), + } + } + } + } +} + +fn core_ty_name(ty: WasmType) -> String { + format!( + "{}", + match ty { + abi::WasmType::I32 => "Word32", + abi::WasmType::I64 => "Word64", + abi::WasmType::F32 => "Float", + abi::WasmType::F64 => "Double", + abi::WasmType::Pointer => "Word32", + abi::WasmType::PointerOrI64 => "Word64", + abi::WasmType::Length => "Word32", + } + ) +} diff --git a/src/bin/wit-bindgen.rs b/src/bin/wit-bindgen.rs index 7f05bd88c..2ed41a3a3 100644 --- a/src/bin/wit-bindgen.rs +++ b/src/bin/wit-bindgen.rs @@ -64,6 +64,15 @@ enum Opt { #[clap(flatten)] args: Common, }, + + /// Generates bindings for Haskell guest modules. + #[cfg(feature = "haskell")] + Haskell { + #[clap(flatten)] + opts: wit_bindgen_haskell::Opts, + #[clap(flatten)] + args: Common, + }, } #[derive(Debug, Parser)] @@ -121,6 +130,8 @@ fn main() -> Result<()> { Opt::TinyGo { opts, args } => (opts.build(), args), #[cfg(feature = "csharp")] Opt::CSharp { opts, args } => (opts.build(), args), + #[cfg(feature = "haskell")] + Opt::Haskell { opts, args } => (opts.build(), args), }; gen_world(generator, &opt, &mut files)?; From 92db6727d03d0ee4ef5e389ffa709467a2de12ae Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Sun, 23 Jun 2024 22:15:10 +0200 Subject: [PATCH 2/7] fixes and cleanup --- crates/haskell/src/lib.rs | 574 +++++++++++++++++++------------------- 1 file changed, 289 insertions(+), 285 deletions(-) diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index ebfd0dd52..c472da391 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -1,6 +1,6 @@ use abi::{AbiVariant, WasmType}; use anyhow::Result; -use heck::{ToLowerCamelCase as _, ToUpperCamelCase as _}; +use heck::{ToLowerCamelCase as _, ToSnakeCase as _, ToUpperCamelCase as _}; use indexmap::{IndexMap, IndexSet}; use wit_bindgen_core; use wit_bindgen_core::abi::{call, Bindgen, Bitcast, Instruction, LiftLower}; @@ -21,7 +21,7 @@ impl Opts { } #[derive(Default)] -pub struct Module { +struct Module { funcs: Source, tydefs: IndexSet, docs: Option, @@ -31,6 +31,7 @@ pub struct Module { #[derive(Default)] pub struct Haskell { modules: IndexMap, + c_header: String, opts: Opts, } @@ -48,7 +49,6 @@ impl WorldGenerator for Haskell { } else { iface.name.clone().unwrap() }; - let iname = upper_ident(None, &iname); let module = if let Some(module) = self.modules.get_mut(&iname) { module } else { @@ -59,17 +59,17 @@ impl WorldGenerator for Haskell { for (name, ty) in &iface.types { module.tydefs.insert(gen_typedef(resolve, name, *ty)); } - for (name, func) in &iface.functions { + for (_name, func) in &iface.functions { module.funcs.push_str(&gen_func_core( resolve, func, - iface.name.as_deref(), + &iname, AbiVariant::GuestImport, )); module.funcs.push_str("\n"); - module - .funcs - .push_str(&gen_func(resolve, &func, iface.name.as_deref())); + module.funcs.push_str(&gen_func(resolve, &func, &iname)); + self.c_header + .push_str(&gen_func_c(resolve, func, &iname, Direction::Import)); } Ok(()) } @@ -87,7 +87,6 @@ impl WorldGenerator for Haskell { } else { iface.name.clone().unwrap() }; - let iname = upper_ident(None, &iname); let module = if let Some(module) = self.modules.get_mut(&iname) { module } else { @@ -101,14 +100,16 @@ impl WorldGenerator for Haskell { if !iface.functions.is_empty() { module.imports_exports = true; } - for (name, func) in &iface.functions { + for (_name, func) in &iface.functions { module.funcs.push_str("\n"); module.funcs.push_str(&gen_func_core( resolve, func, - iface.name.as_deref(), + &iname, AbiVariant::GuestExport, )); + self.c_header + .push_str(&gen_func_c(resolve, func, &iname, Direction::Export)); } Ok(()) @@ -122,23 +123,25 @@ impl WorldGenerator for Haskell { _files: &mut Files, ) { let world = &resolve.worlds[world]; - let world_name = upper_ident(None, &world.name); - let module = if let Some(module) = self.modules.get_mut(&world_name) { + let module = if let Some(module) = self.modules.get_mut(&world.name) { module } else { - self.modules.insert(world_name.clone(), Default::default()); - self.modules.get_mut(&world_name).unwrap() + self.modules.insert(world.name.clone(), Default::default()); + self.modules.get_mut(&world.name).unwrap() }; module.docs = world.docs.contents.clone(); - for (name, func) in funcs { - module - .funcs - .push_str(&gen_func_core(resolve, func, None, AbiVariant::GuestImport)); + for (_name, func) in funcs { + module.funcs.push_str(&gen_func_core( + resolve, + func, + &world.name, + AbiVariant::GuestImport, + )); module.funcs.push_str("\n"); - module - .funcs - .push_str(&gen_func(resolve, func, Some(&world_name))); + module.funcs.push_str(&gen_func(resolve, func, &world.name)); module.funcs.push_str("\n"); + self.c_header + .push_str(&gen_func_c(resolve, func, &world.name, Direction::Import)); } } @@ -150,22 +153,26 @@ impl WorldGenerator for Haskell { _files: &mut Files, ) -> Result<()> { let world = &resolve.worlds[world]; - let world_name = upper_ident(None, &world.name); - let module = if let Some(module) = self.modules.get_mut(&world_name) { + let module = if let Some(module) = self.modules.get_mut(&world.name) { module } else { - self.modules.insert(world_name.clone(), Default::default()); - self.modules.get_mut(&world_name).unwrap() + self.modules.insert(world.name.clone(), Default::default()); + self.modules.get_mut(&world.name).unwrap() }; if !funcs.is_empty() { module.imports_exports = true; } module.docs = world.docs.contents.clone(); - for (name, func) in funcs { - module - .funcs - .push_str(&gen_func_core(resolve, func, None, AbiVariant::GuestExport)); + for (_name, func) in funcs { + module.funcs.push_str(&gen_func_core( + resolve, + func, + &world.name, + AbiVariant::GuestExport, + )); module.funcs.push_str("\n"); + self.c_header + .push_str(&gen_func_c(resolve, func, &world.name, Direction::Export)); } Ok(()) } @@ -178,12 +185,11 @@ impl WorldGenerator for Haskell { _files: &mut Files, ) { let world = &resolve.worlds[world]; - let world_name: String = upper_ident(None, &world.name); - let module = if let Some(module) = self.modules.get_mut(&world_name) { + let module = if let Some(module) = self.modules.get_mut(&world.name) { module } else { - self.modules.insert(world_name.clone(), Default::default()); - self.modules.get_mut(&world_name).unwrap() + self.modules.insert(world.name.clone(), Default::default()); + self.modules.get_mut(&world.name).unwrap() }; module.docs = world.docs.contents.clone(); module.tydefs.insert( @@ -197,19 +203,21 @@ impl WorldGenerator for Haskell { fn finish(&mut self, _resolve: &Resolve, _world: WorldId, files: &mut Files) -> Result<()> { for (name, module) in self.modules.iter_mut() { + let name = upper_ident(name); let contents = gen_module( - name, + &name, &module.funcs, module.imports_exports, !module.tydefs.is_empty(), &module.docs, ); - files.push(&format!("{name}.hs"), &contents); + files.push(&format!("{}.hs", name.replace('.', "/")), &contents); if module.tydefs.is_empty() { continue; } + let name = format!("{name}.Types"); let contents = gen_module( - &format!("Types.{name}"), + &name, &module .tydefs .iter() @@ -220,8 +228,10 @@ impl WorldGenerator for Haskell { false, &module.docs, ); - files.push(&format!("Types.{name}.hs"), &contents); + files.push(&format!("{}.hs", name.replace('.', "/")), &contents); } + let c_header = format!("#include \n\n{}", self.c_header); + files.push("bg_foreign.h", c_header.as_bytes()); Ok(()) } } @@ -230,11 +240,12 @@ fn gen_module( name: &str, src: &str, imports_exports: bool, - import_types: bool, + imports_types: bool, docs: &Option, ) -> Vec { format!( "\ +{{-# LANGUAGE CApiFFI #-}} -- Generated by wit-bindgen. {} @@ -262,13 +273,13 @@ import Foreign.Marshal.Array; } else { "".to_owned() }, - if import_types { - format!("\nimport Types.{name};\n") + if imports_types { + format!("import {name}.Types;\n") } else { "".to_owned() }, if imports_exports { - format!("\nimport qualified Exports.{name};\n") + format!("import qualified {name}.Exports;\n") } else { "".to_owned() }, @@ -279,8 +290,7 @@ import Foreign.Marshal.Array; } struct HsFunc<'a> { - ns: Option<&'a str>, - dual_func: String, + dual_func: &'a str, params: Vec, blocks: Vec, var_count: usize, @@ -288,6 +298,16 @@ struct HsFunc<'a> { variant: AbiVariant, } +impl<'a> HsFunc<'a> { + fn var(&mut self) -> String { + self.var_count += 1; + format!("bg_v{}", self.var_count - 1) + } + fn vars(&mut self, amount: usize) -> Vec { + (0..amount).map(|_| self.var()).collect() + } +} + fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { let mut src = String::new(); let ty = &resolve.types[id]; @@ -302,7 +322,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { } match &ty.kind { TypeDefKind::Record(record) => { - let record_name = upper_ident(None, name); + let record_name = upper_ident(name); src.push_str(&format!( "data {record_name} = {record_name} {{ {} }};\n", record @@ -311,7 +331,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { .map(|field| { format!( "{} :: {}", - lower_ident(None, &[name, &field.name].join("-")), + lower_ident(&[name, &field.name].join("-")), ty_name(resolve, false, &field.ty) ) }) @@ -320,23 +340,20 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { )); } TypeDefKind::Resource => { - let resource_name = upper_ident(None, name); + let resource_name = upper_ident(name); src.push_str(&format!( "newtype {resource_name} = {resource_name} Word32;\n" )); } TypeDefKind::Handle(_) => todo!(), TypeDefKind::Flags(flags) => { - let flags_name = upper_ident(None, name); + let flags_name = upper_ident(name); src.push_str(&format!( "data {flags_name} = {flags_name} {{ {} }};\n", flags .flags .iter() - .map(|flag| format!( - "{} :: Bool", - lower_ident(None, &[name, &flag.name].join("-")) - )) + .map(|flag| format!("{} :: Bool", lower_ident(&[name, &flag.name].join("-")))) .collect::>() .join(", ") )); @@ -349,7 +366,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { .map(|case| { format!( "{} {}", - upper_ident(None, &[name, &case.name].join("-")), + upper_ident(&[name, &case.name].join("-")), if let Some(ty) = case.ty { ty_name(resolve, false, &ty) } else { @@ -359,18 +376,18 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { }) .collect::>() .join(" | "); - src.push_str(&format!("data {} = {cases};\n", upper_ident(None, name))) + src.push_str(&format!("data {} = {cases};\n", upper_ident(name))) } TypeDefKind::Enum(enu) => { let cases = enu .cases .iter() - .map(|case| upper_ident(None, &[name, &case.name].join("-"))) + .map(|case| upper_ident(&[name, &case.name].join("-"))) .collect::>() .join(" | "); - src.push_str(&format!("data {} = {cases};\n", upper_ident(None, name))) + src.push_str(&format!("data {} = {cases};\n", upper_ident(name))) } - TypeDefKind::Option(ty) => todo!(), + TypeDefKind::Option(_) => todo!(), TypeDefKind::Result(_) => todo!(), TypeDefKind::List(_) => todo!(), TypeDefKind::Future(_) => todo!(), @@ -378,7 +395,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { TypeDefKind::Type(ty) => { src.push_str(&format!( "type {} = {};\n", - upper_ident(None, name), + upper_ident(name), ty_name(resolve, false, ty) )); } @@ -420,143 +437,130 @@ impl<'a> Bindgen for HsFunc<'a> { .to_owned() })), Instruction::I32Load { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::I32Load8U { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word8 -> IO Word8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] - )); - results.push(format!( - "((fromIntegral :: Word8 -> Word32) bg_v{})", - self.var_count + "{var} <- (peek :: Ptr Word8 -> IO Word8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", operands[0] )); - self.var_count += 1; + results.push(format!("((fromIntegral :: Word8 -> Word32) {var})")); } Instruction::I32Load8S { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Int8 -> IO Int8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] - )); - results.push(format!( - "((fromIntegral :: Int8 -> Word32) bg_v{})", - self.var_count + "{var} <- (peek :: Ptr Int8 -> IO Int8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - self.var_count += 1; + results.push(format!("((fromIntegral :: Int8 -> Word32) {var})")); } Instruction::I32Load16U { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word16 -> IO Word16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Word16 -> IO Word16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!( - "((fromIntegral :: Word16 -> Word32) bg_v{})", - self.var_count - )); - self.var_count += 1; + results.push(format!("((fromIntegral :: Word16 -> Word32) {var})")); } Instruction::I32Load16S { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Int16 -> IO Int16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] - )); - results.push(format!( - "((fromIntegral :: Int16 -> Word32) bg_v{})", - self.var_count + "{var} <- (peek :: Ptr Int16 -> IO Int16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - self.var_count += 1; + results.push(format!("((fromIntegral :: Int16 -> Word32) {var})")); } Instruction::I64Load { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word64 -> IO Word64) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Word64 -> IO Word64) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::F32Load { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Float -> IO Float) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Float -> IO Float) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::F64Load { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Double -> IO Double) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Double -> IO Double) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::PointerLoad { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::LengthLoad { offset } => { + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", - self.var_count, operands[0] + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::I32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", - operands[0], operands[1] + "(poke :: Ptr 32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[1], operands[0] )); } Instruction::I32Store8 { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Word8 -> Word8 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word8) {});\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::I32Store16 { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Word16 -> Word16 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word16) {});\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::I64Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Word64 -> Word64 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::F32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Float -> Float -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::F64Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Double -> Double -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::PointerStore { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", - operands[0], operands[1] + operands[1], operands[0] )); } Instruction::LengthStore { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word32) {});\n", - operands[0], operands[1] + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + operands[1], operands[0] )); } Instruction::I32FromChar => results.push(format!( @@ -568,10 +572,7 @@ impl<'a> Bindgen for HsFunc<'a> { "((fromIntegral :: Int64 -> Word64) {})", operands[0] )), - Instruction::I32FromU32 => results.push(format!( - "((fromIntegral :: Word32 -> Word64) {})", - operands[0] - )), + Instruction::I32FromU32 => results.push(operands[0].clone()), Instruction::I32FromS32 => results.push(format!( "((fromIntegral :: Int32 -> Word32) {})", operands[0] @@ -632,9 +633,8 @@ impl<'a> Bindgen for HsFunc<'a> { )), Instruction::ListCanonLower { element, realloc } => { let list = operands[0].clone(); - let ptr: String = format!("bg_v{}", self.var_count); - let len = format!("bg_v{}", self.var_count + 1); - self.var_count += 2; + let ptr = self.var(); + let len = self.var(); self.blocks .last_mut() .unwrap() @@ -647,12 +647,14 @@ impl<'a> Bindgen for HsFunc<'a> { .last_mut() .unwrap() .push_str(&format!("pokeArray {ptr} {list};\n",)); - results.extend([ptr, len]); + results.extend([ + format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {ptr}))"), + format!("((fromIntegral :: Int -> Word32) {len})"), + ]); } Instruction::StringLower { realloc } => { - let ptr: String = format!("bg_v{}", self.var_count); - let len = format!("bg_v{}", self.var_count + 1); - self.var_count += 2; + let ptr: String = self.var(); + let len = self.var(); self.blocks .last_mut() .unwrap() @@ -668,15 +670,17 @@ impl<'a> Bindgen for HsFunc<'a> { .last_mut() .unwrap() .push_str(&format!("pokeArray {ptr} bg_tmp;\n")); - results.extend([ptr, len]); + results.extend([ + format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {ptr}))"), + format!("((fromIntegral :: Int -> Word32) {len})"), + ]); } Instruction::ListLower { element, realloc } => { let size = self.size_align.size(element); let list = operands[0].clone(); let block = self.blocks.pop().unwrap(); - let list_len = format!("bg_v{}", self.var_count + 1); - let list_ptr = format!("bg_v{}", self.var_count); - self.var_count += 2; + let list_len = self.var(); + let list_ptr = self.var(); self.blocks .last_mut() .unwrap() @@ -689,44 +693,45 @@ impl<'a> Bindgen for HsFunc<'a> { "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}\n}}) (zip (enumFromThenTo {list_ptr} ({list_ptr} + {size}) ({list_len} * {size} - {size})) {list});\n", block.to_string() )); - results.extend([list_ptr, list_len]); + results.extend([ + format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {list_ptr}))"), + format!("((fromIntegral :: Int -> Word32) {list_len})"), + ]); } Instruction::ListCanonLift { element, ty } => { let ty = ty_name(resolve, false, element); - let ptr = operands[0].clone(); - let len = operands[1].clone(); + let len = operands[0].clone(); + let ptr = operands[1].clone(); + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) {len} (wordPtrToPtr {ptr}));\n", - self.var_count + "{var} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) {len} (wordPtrToPtr {ptr}));\n" )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::StringLift => { - let ptr = operands[0].clone(); - let len = operands[1].clone(); + let len: String = operands[0].clone(); + let ptr = operands[1].clone(); + let var = self.var(); self.blocks .last_mut() .unwrap() - .push_str(&format!("bg_v{} <- return (decodeUtf8 ((pack :: [Word8] -> ByteString) ((peekArray :: Int -> Ptr Word8 -> IO [Word8]) {len} (wordPtrToPtr {ptr}))));\n", self.var_count)); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + .push_str(&format!("{var} <- return (decodeUtf8 ((pack :: [Word8] -> ByteString) ((peekArray :: Int -> Ptr Word8 -> IO [Word8]) {len} (wordPtrToPtr {ptr}))));\n")); + results.push(var); } Instruction::ListLift { element, ty } => { let size = self.size_align.size(element); - let ptr = operands[0].clone(); - let len = operands[1].clone(); + let len = operands[0].clone(); + let ptr = operands[1].clone(); let block = self.blocks.pop().unwrap(); + let var = self.var(); self.blocks .last_mut() .unwrap() .push_str(&format!( - "bg_v{} <- mapM (\\bg_base_ptr -> do {{\n{};\nreturn bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", - self.var_count, + "{var} <- mapM (\\bg_base_ptr -> do {{\n{};\nreturn bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", block.to_string() )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::IterElem { element } => { results.push("bg_elem".to_owned()); @@ -738,7 +743,7 @@ impl<'a> Bindgen for HsFunc<'a> { results.extend(record.fields.iter().map(|field| { format!( "({} {})", - lower_ident(self.ns, &format!("{name}-{}", field.name)), + lower_ident(&format!("{name}-{}", field.name)), operands[0] ) })); @@ -749,30 +754,21 @@ impl<'a> Bindgen for HsFunc<'a> { .iter() .zip(operands) .map(|(field, op)| { - format!( - "{} = {op}", - lower_ident(self.ns, &format!("{name}-{}", field.name)) - ) + format!("{} = {op}", lower_ident(&format!("{name}-{}", field.name))) }) .collect::>() .join(", "); - results.push(format!("{{ {} }}", fields)); + results.push(format!("({} {{ {} }})", upper_ident(name), fields)); } Instruction::HandleLower { handle, name, ty } => todo!(), Instruction::HandleLift { handle, name, ty } => todo!(), Instruction::TupleLower { tuple, ty } => { - let fields = tuple - .types - .iter() - .enumerate() - .map(|(i, _)| format!("bg_v{}", self.var_count + i)) - .collect::>(); + let fields = self.vars(tuple.types.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- return ({});\n", fields.join(", "), operands[0] )); - self.var_count += fields.len(); results.extend(fields); } Instruction::TupleLift { tuple, ty } => { @@ -782,7 +778,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::FlagsLift { flags, name, ty } => { results.push(format!( "({} {{ {} }})", - upper_ident(None, name), + upper_ident(name), flags .flags .iter() @@ -790,7 +786,7 @@ impl<'a> Bindgen for HsFunc<'a> { .map(|(i, flag)| { format!( "{} = ((shiftR {} {i}) (.&.) 1) == 1)", - flag.name, + lower_ident(&format!("{name}-{}", flag.name)), operands[0 / 32] ) }) @@ -815,26 +811,21 @@ impl<'a> Bindgen for HsFunc<'a> { .map(|(case, block)| { format!( "{}{}{} -> do {{\n{}; return bg_v }}", - upper_ident(None, name), - upper_ident(None, &case.name), + upper_ident(name), + upper_ident(&case.name), if case.ty.is_some() { " bg_payload" } else { "" }, block.to_string() ) }) .collect::>() .join(";\n"); - let vars = types - .iter() - .enumerate() - .map(|(i, _)| format!("bg_v{}", self.var_count + i)) - .collect::>(); + let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- (case {} of {{\n{cases} }});\n", vars.join(", "), operands[0] )); results.extend(vars); - self.var_count += types.len(); } Instruction::VariantLift { variant, name, ty } => { let blocks = self.blocks.drain(self.blocks.len() - variant.cases.len()..); @@ -847,18 +838,18 @@ impl<'a> Bindgen for HsFunc<'a> { format!( "{i} -> do {{ {};\n(return ({}{} bg_v))\n}}\n", block.to_string(), - ty_name(resolve, false, &Type::Id(*ty)), - upper_ident(None, &case.name), + upper_ident(name), + upper_ident(&case.name), ) }) .collect::>() .join(";\n"); + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (case {} of {{\n{cases} }})", - self.var_count, operands[0] + "{var} <- (case {} of {{\n{cases} }})", + operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::EnumLower { enum_, name, ty } => { let arms = enum_ @@ -868,8 +859,8 @@ impl<'a> Bindgen for HsFunc<'a> { .map(|(i, case)| { format!( "{}{} -> {i}", - ty_name(resolve, false, &Type::Id(*ty)), - upper_ident(None, &format!("{}", case.name)) + upper_ident(name), + upper_ident(&format!("{}", case.name)) ) }) .collect::>() @@ -883,17 +874,19 @@ impl<'a> Bindgen for HsFunc<'a> { .enumerate() .map(|(i, case)| { format!( - "{i} -> {}{}", - ty_name(resolve, false, &Type::Id(*ty)), - upper_ident(None, &case.name) + "{} -> {}{}", + if i == enum_.cases.len() - 1 { + "_".to_owned() + } else { + i.to_string() + }, + upper_ident(name), + upper_ident(&case.name) ) }) .collect::>() .join(";\n"); - results.push(format!( - "(case {} of {{\n{arms};\n_ -> error \"\" }})", - operands[0] - )); + results.push(format!("(case {} of {{\n{arms} }})", operands[0])); } Instruction::OptionLower { payload, @@ -902,12 +895,7 @@ impl<'a> Bindgen for HsFunc<'a> { } => { let some = self.blocks.pop().unwrap().to_string(); let none = self.blocks.pop().unwrap().to_string(); - let vars = types - .iter() - .enumerate() - .map(|(i, _)| format!("bg_v{}", self.var_count + i)) - .collect::>(); - self.var_count += vars.len(); + let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- case {} of {{\nNothing -> do {{\n{none}\n}};\nJust bg_payload -> do {{\n{some}\n}} }}\n", vars.join(", "), @@ -918,13 +906,12 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::OptionLift { payload, ty } => { let some = self.blocks.pop().unwrap().to_string(); let none = self.blocks.pop().unwrap().to_string(); + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (case {} of\n0 -> (do {{\n{none};\nreturn Nothing\n}});\n1 -> (do {{\n{some});\nreturn (Just bg_v)\n}})))", - self.var_count, + "{var} <- (case {} of\n0 -> (do {{\n{none};\nreturn Nothing\n}});\n_ -> (do {{\n{some});\nreturn (Just bg_v)\n}})))", operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::ResultLower { result, @@ -933,12 +920,7 @@ impl<'a> Bindgen for HsFunc<'a> { } => { let ok = self.blocks.pop().unwrap().to_string(); let err = self.blocks.pop().unwrap().to_string(); - let vars = types - .iter() - .enumerate() - .map(|(i, _)| format!("bg_v{}", self.var_count + i)) - .collect::>(); - self.var_count += vars.len(); + let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}\n}};\nRight bg_payload -> do {{\n{ok}\n}} }}\n", vars.join(", "), @@ -949,21 +931,15 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::ResultLift { result, ty } => { let err = self.blocks.pop().unwrap().to_string(); let ok = self.blocks.pop().unwrap().to_string(); + let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "bg_v{} <- (case {} of\n0 -> (do {{\n{err};\nreturn (Left bg_v)\n}});\n1 -> (do {{\n{ok});\nreturn (Right bg_v)\n}})))", - self.var_count, + "{var} <- (case {} of\n0 -> (do {{\n{ok};\nreturn (Right bg_v)\n}});\n_ -> (do {{\n{err});\nreturn (Left bg_v)\n}})))", operands[0] )); - results.push(format!("bg_v{}", self.var_count)); - self.var_count += 1; + results.push(var); } Instruction::CallWasm { name, sig } => { - let vars = sig - .results - .iter() - .enumerate() - .map(|(i, _result)| format!("bg_v{}", self.var_count + i)) - .collect::>(); + let vars = self.vars(sig.results.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- ({} {});\n", vars.join(", "), @@ -971,13 +947,9 @@ impl<'a> Bindgen for HsFunc<'a> { operands.join(" ") )); results.extend(vars); - self.var_count += sig.results.len(); } Instruction::CallInterface { func } => { - let vars = (0..func.results.len()) - .map(|i| format!("bg_v{}", self.var_count + i)) - .collect::>(); - self.var_count += vars.len(); + let vars = self.vars(func.results.len()); self.blocks.last_mut().unwrap().push_str(&format!( "({}) <- ({} {});\n", vars.join(", "), @@ -1033,8 +1005,7 @@ impl<'a> Bindgen for HsFunc<'a> { fn is_list_canonical(&self, _resolve: &Resolve, element: &Type) -> bool { match element { - Type::Bool - | Type::U8 + Type::U8 | Type::U16 | Type::U32 | Type::U64 @@ -1045,7 +1016,7 @@ impl<'a> Bindgen for HsFunc<'a> { | Type::F32 | Type::F64 | Type::Char => true, - Type::String | Type::Id(_) => false, + Type::Bool | Type::String | Type::Id(_) => false, } } } @@ -1084,7 +1055,7 @@ fn bitcast(op: &String, cast: &Bitcast) -> String { } } -fn gen_func(resolve: &Resolve, func: &Function, ns: Option<&str>) -> String { +fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { let mut src = String::new(); if let Some(docs) = &func.docs.contents { src.push_str("\n"); @@ -1127,12 +1098,11 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: Option<&str>) -> String { let mut size_align = SizeAlign::new(AddressSize::Wasm32); size_align.fill(resolve); let mut bindgen = HsFunc { - ns: None, - dual_func: func_name_foreign(func, ns, Direction::Import), + dual_func: &func_name_foreign(func, ns, Direction::Import), params: func .params .iter() - .map(|(name, _ty)| lower_ident(None, &name)) + .map(|(name, _ty)| lower_ident(&name)) .collect(), blocks: vec![Source::default()], var_count: 0, @@ -1158,32 +1128,25 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: Option<&str>) -> String { src } -fn gen_func_core( - resolve: &Resolve, - func: &Function, - ns: Option<&str>, - variant: AbiVariant, -) -> String { +fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVariant) -> String { let mut src = String::new(); let sig = resolve.wasm_signature(variant, func); - src.push_str(&format!( - "foreign {} ccall \"{}\" {} :: ", + let name_foreign = func_name_foreign( + func, + ns, if variant == AbiVariant::GuestExport { - "export" + Direction::Export } else { - "import" + Direction::Import }, - func.core_export_name(ns), - func_name_foreign( - func, - ns, - if variant == AbiVariant::GuestExport { - Direction::Export - } else { - Direction::Import - } - ), - )); + ); + src.push_str( + &(if variant == AbiVariant::GuestExport { + format!("foreign export capi \"{name_foreign}\" {name_foreign} :: ") + } else { + format!("foreign import capi \"bg_foreign.h {name_foreign}\" {name_foreign} :: ") + }), + ); src.push_str( &sig.params .iter() @@ -1208,8 +1171,7 @@ fn gen_func_core( let mut size_align = SizeAlign::new(AddressSize::Wasm32); size_align.fill(resolve); let mut bindgen = HsFunc { - ns: None, - dual_func: func_name(func, ns), + dual_func: &func_name(func, Some(&ns)), params: sig .params .iter() @@ -1222,11 +1184,7 @@ fn gen_func_core( variant, }; src.push('\n'); - src.push_str(&format!( - "{} {} = ", - func_name_foreign(func, ns, Direction::Export), - bindgen.params.join(" ") - )); + src.push_str(&format!("{} {} = ", name_foreign, bindgen.params.join(" "))); call( resolve, AbiVariant::GuestExport, @@ -1240,49 +1198,95 @@ fn gen_func_core( src } -fn func_name_foreign(func: &Function, ns: Option<&str>, dir: Direction) -> String { +fn gen_func_c(resolve: &Resolve, func: &Function, ns: &str, dir: Direction) -> String { + let sig = resolve.wasm_signature(AbiVariant::GuestImport, func); + let func_name_foreign = func_name_foreign(func, ns, dir); + let symbol = func.core_export_name(Some(ns)); + let ret_ty = match sig.results.as_slice() { + [] => "void".to_owned(), + [ty] => ty_name_c(ty), + _ => unimplemented!(), + }; + let params = sig + .params + .iter() + .enumerate() + .map(|(i, ty)| format!("{} bg_p{i}", ty_name_c(ty))) + .collect::>() + .join(", "); + let vars = sig + .params + .iter() + .enumerate() + .map(|(i, _)| format!("bg_p{i}")) + .collect::>() + .join(", "); + if dir == Direction::Import { + format!( + "\ +{ret_ty} {func_name_foreign}({params}) __attribute__(( + __import_module__(\"\"), + __import_name__(\"{symbol}\") +)); + +", + ) + } else { + let func_name_export = [ns, &func.name].join("-").to_snake_case(); + format!( + "\ +{ret_ty} {func_name_export}({params}) __attribute__(( + __export_name__(\"{symbol}\") +)); +{ret_ty} {func_name_export}({params}) {{ + return {func_name_foreign}({vars}); +}} + +", + ) + } +} + +fn ty_name_c(ty: &WasmType) -> String { + match ty { + WasmType::I32 => "uint32_t".to_owned(), + WasmType::I64 => "uint64_t".to_owned(), + WasmType::F32 => "float".to_owned(), + WasmType::F64 => "double".to_owned(), + WasmType::Pointer => "uint32_t".to_owned(), + WasmType::PointerOrI64 => "uint64_t".to_owned(), + WasmType::Length => "uint32_t".to_owned(), + } +} + +fn func_name_foreign(func: &Function, ns: &str, dir: Direction) -> String { format!( - "bg_fn_{}_{}", + "bg_fn_{}_{}_{}", if dir == Direction::Import { "imp" } else { "exp" }, - lower_ident(ns, &func.core_export_name(None)) + upper_ident(ns), + lower_ident(&func.core_export_name(None)) .replace(|c: char| !c.is_ascii_alphanumeric(), "_") ) } fn func_name(func: &Function, ns: Option<&str>) -> String { if let Some(ns) = ns { - format!("Exports.{}", lower_ident(Some(ns), &func.name)) + format!("{}.Exports.{}", upper_ident(ns), lower_ident(&func.name)) } else { - lower_ident(None, &func.name) + lower_ident(&func.name) } } -fn lower_ident(ns: Option<&str>, name: &str) -> String { - format!( - "{}{}", - if let Some(ns) = ns { - format!("{}.", upper_ident(None, &ns)) - } else { - "".to_owned() - }, - name.to_lower_camel_case() - ) +fn lower_ident(name: &str) -> String { + name.to_lower_camel_case() } -fn upper_ident(ns: Option<&str>, name: &str) -> String { - format!( - "{}{}", - if let Some(ns) = ns { - format!("{}.", ns.to_upper_camel_case()) - } else { - "".to_owned() - }, - name.to_upper_camel_case() - ) +fn upper_ident(name: &str) -> String { + name.to_upper_camel_case() } fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { @@ -1317,12 +1321,12 @@ fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { } else { None }; - let ns = ns.map(|n| format!("Types.{}", upper_ident(None, &n))); + let ns = ns.map(|n| format!("Types.{}", upper_ident(&n))); if let Some(name) = &ty.name { if let Some(ns) = ns { - format!("{ns}.{}", upper_ident(None, name)) + format!("{ns}.{}", upper_ident(name)) } else { - upper_ident(ns.as_deref(), name) + upper_ident(name) } } else { match &ty.kind { From 3c70229a545820b0d0204643d8d07dc984828521 Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Wed, 26 Jun 2024 18:24:59 +0200 Subject: [PATCH 3/7] remove cyclic module dependencies --- crates/haskell/src/lib.rs | 218 ++++++++++++++++++++------------------ 1 file changed, 117 insertions(+), 101 deletions(-) diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index c472da391..8bac3a2b6 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -22,7 +22,8 @@ impl Opts { #[derive(Default)] struct Module { - funcs: Source, + funcs_imp: Source, + funcs_exp: Source, tydefs: IndexSet, docs: Option, imports_exports: bool, @@ -60,14 +61,14 @@ impl WorldGenerator for Haskell { module.tydefs.insert(gen_typedef(resolve, name, *ty)); } for (_name, func) in &iface.functions { - module.funcs.push_str(&gen_func_core( + module.funcs_imp.push_str(&gen_func_core( resolve, func, &iname, AbiVariant::GuestImport, )); - module.funcs.push_str("\n"); - module.funcs.push_str(&gen_func(resolve, &func, &iname)); + module.funcs_imp.push_str("\n"); + module.funcs_imp.push_str(&gen_func(resolve, &func, &iname)); self.c_header .push_str(&gen_func_c(resolve, func, &iname, Direction::Import)); } @@ -101,8 +102,8 @@ impl WorldGenerator for Haskell { module.imports_exports = true; } for (_name, func) in &iface.functions { - module.funcs.push_str("\n"); - module.funcs.push_str(&gen_func_core( + module.funcs_exp.push_str("\n"); + module.funcs_exp.push_str(&gen_func_core( resolve, func, &iname, @@ -111,7 +112,6 @@ impl WorldGenerator for Haskell { self.c_header .push_str(&gen_func_c(resolve, func, &iname, Direction::Export)); } - Ok(()) } @@ -131,15 +131,17 @@ impl WorldGenerator for Haskell { }; module.docs = world.docs.contents.clone(); for (_name, func) in funcs { - module.funcs.push_str(&gen_func_core( + module.funcs_imp.push_str(&gen_func_core( resolve, func, &world.name, AbiVariant::GuestImport, )); - module.funcs.push_str("\n"); - module.funcs.push_str(&gen_func(resolve, func, &world.name)); - module.funcs.push_str("\n"); + module.funcs_imp.push_str("\n"); + module + .funcs_imp + .push_str(&gen_func(resolve, func, &world.name)); + module.funcs_imp.push_str("\n"); self.c_header .push_str(&gen_func_c(resolve, func, &world.name, Direction::Import)); } @@ -164,13 +166,13 @@ impl WorldGenerator for Haskell { } module.docs = world.docs.contents.clone(); for (_name, func) in funcs { - module.funcs.push_str(&gen_func_core( + module.funcs_exp.push_str(&gen_func_core( resolve, func, &world.name, AbiVariant::GuestExport, )); - module.funcs.push_str("\n"); + module.funcs_exp.push_str("\n"); self.c_header .push_str(&gen_func_c(resolve, func, &world.name, Direction::Export)); } @@ -204,31 +206,42 @@ impl WorldGenerator for Haskell { fn finish(&mut self, _resolve: &Resolve, _world: WorldId, files: &mut Files) -> Result<()> { for (name, module) in self.modules.iter_mut() { let name = upper_ident(name); - let contents = gen_module( - &name, - &module.funcs, - module.imports_exports, - !module.tydefs.is_empty(), - &module.docs, - ); - files.push(&format!("{}.hs", name.replace('.', "/")), &contents); - if module.tydefs.is_empty() { - continue; + if !module.funcs_imp.is_empty() { + let contents = gen_module( + &name, + &module.funcs_imp, + ModuleKind::Imports { + imports_types: !module.tydefs.is_empty(), + }, + &module.docs, + ); + files.push(&format!("{}/Imports.hs", name.replace('.', "/")), &contents); + } + if !module.funcs_exp.is_empty() { + let contents = gen_module( + &name, + &module.funcs_exp, + ModuleKind::Exports { + imports_types: !module.tydefs.is_empty(), + }, + &module.docs, + ); + files.push(&format!("{}/Exports.hs", name.replace('.', "/")), &contents); + } + if !module.tydefs.is_empty() { + let contents = gen_module( + &name, + &module + .tydefs + .iter() + .cloned() + .collect::>() + .join("\n"), + ModuleKind::Types, + &module.docs, + ); + files.push(&format!("{}/Types.hs", name.replace('.', "/")), &contents); } - let name = format!("{name}.Types"); - let contents = gen_module( - &name, - &module - .tydefs - .iter() - .map(|m| m.clone()) - .collect::>() - .join("\n"), - false, - false, - &module.docs, - ); - files.push(&format!("{}.hs", name.replace('.', "/")), &contents); } let c_header = format!("#include \n\n{}", self.c_header); files.push("bg_foreign.h", c_header.as_bytes()); @@ -236,20 +249,25 @@ impl WorldGenerator for Haskell { } } -fn gen_module( - name: &str, - src: &str, - imports_exports: bool, - imports_types: bool, - docs: &Option, -) -> Vec { +enum ModuleKind { + Imports { imports_types: bool }, + Exports { imports_types: bool }, + Types, +} + +fn gen_module(name: &str, src: &str, module_kind: ModuleKind, docs: &Option) -> Vec { + let module_name = match module_kind { + ModuleKind::Imports { .. } => format!("{name}.Imports"), + ModuleKind::Exports { .. } => format!("{name}.Exports"), + ModuleKind::Types => format!("{name}.Types"), + }; format!( "\ {{-# LANGUAGE CApiFFI #-}} -- Generated by wit-bindgen. {} -module {name} where +module {module_name} where import Data.Word; import Data.Int; @@ -273,13 +291,20 @@ import Foreign.Marshal.Array; } else { "".to_owned() }, - if imports_types { + if matches!( + module_kind, + ModuleKind::Imports { + imports_types: true + } | ModuleKind::Exports { + imports_types: true + } + ) { format!("import {name}.Types;\n") } else { "".to_owned() }, - if imports_exports { - format!("import qualified {name}.Exports;\n") + if matches!(module_kind, ModuleKind::Exports { .. }) { + format!("import qualified {name};\n") } else { "".to_owned() }, @@ -635,18 +660,13 @@ impl<'a> Bindgen for HsFunc<'a> { let list = operands[0].clone(); let ptr = self.var(); let len = self.var(); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("{len} <- length {list};\n")); - self.blocks.last_mut().unwrap().push_str(&format!( + let current_block = self.blocks.last_mut().unwrap(); + current_block.push_str(&format!("{len} <- length {list};\n")); + current_block.push_str(&format!( "{ptr} <- (callocBytes :: Int -> IO (Ptr [{}])) {len};\n", ty_name(resolve, false, element) )); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("pokeArray {ptr} {list};\n",)); + current_block.push_str(&format!("pokeArray {ptr} {list};\n",)); results.extend([ format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {ptr}))"), format!("((fromIntegral :: Int -> Word32) {len})"), @@ -655,21 +675,16 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::StringLower { realloc } => { let ptr: String = self.var(); let len = self.var(); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("bg_tmp <- unpack (encodeUtf8 {});\n", operands[0])); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("{len} <- length bg_tmp;\n")); - self.blocks.last_mut().unwrap().push_str(&format!( + let current_block = self.blocks.last_mut().unwrap(); + current_block.push_str(&format!( + "bg_tmp <- return (unpack (encodeUtf8 {}));\n", + operands[0] + )); + current_block.push_str(&format!("{len} <- return (length bg_tmp);\n")); + current_block.push_str(&format!( "{ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) {len};\n" )); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("pokeArray {ptr} bg_tmp;\n")); + current_block.push_str(&format!("pokeArray {ptr} bg_tmp;\n")); results.extend([ format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {ptr}))"), format!("((fromIntegral :: Int -> Word32) {len})"), @@ -681,15 +696,13 @@ impl<'a> Bindgen for HsFunc<'a> { let block = self.blocks.pop().unwrap(); let list_len = self.var(); let list_ptr = self.var(); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("{list_len} <- length {list};\n",)); - self.blocks.last_mut().unwrap().push_str(&format!( + let current_block = self.blocks.last_mut().unwrap(); + current_block.push_str(&format!("{list_len} <- length {list};\n",)); + current_block.push_str(&format!( "{list_ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) ({list_len} * {});\n", size )); - self.blocks.last_mut().unwrap().push_str(&format!( + current_block.push_str(&format!( "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}\n}}) (zip (enumFromThenTo {list_ptr} ({list_ptr} + {size}) ({list_len} * {size} - {size})) {list});\n", block.to_string() )); @@ -700,35 +713,34 @@ impl<'a> Bindgen for HsFunc<'a> { } Instruction::ListCanonLift { element, ty } => { let ty = ty_name(resolve, false, element); - let len = operands[0].clone(); - let ptr = operands[1].clone(); + let ptr = operands[0].clone(); + let len = operands[1].clone(); let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) {len} (wordPtrToPtr {ptr}));\n" + "{var} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) (fromIntegral {len}) (wordPtrToPtr {ptr}));\n" )); results.push(var); } Instruction::StringLift => { - let len: String = operands[0].clone(); - let ptr = operands[1].clone(); + let ptr = operands[0].clone(); + let len: String = operands[1].clone(); let var = self.var(); - self.blocks - .last_mut() - .unwrap() - .push_str(&format!("{var} <- return (decodeUtf8 ((pack :: [Word8] -> ByteString) ((peekArray :: Int -> Ptr Word8 -> IO [Word8]) {len} (wordPtrToPtr {ptr}))));\n")); + let current_block = self.blocks.last_mut().unwrap(); + current_block.push_str(&format!("bg_tmp <- (peekArray :: Int -> Ptr Word8 -> IO [Word8]) (fromIntegral {len}) (wordPtrToPtr {ptr});\n")); + current_block.push_str(&format!("{var} <- return (decodeUtf8 (pack bg_tmp));\n")); results.push(var); } Instruction::ListLift { element, ty } => { let size = self.size_align.size(element); - let len = operands[0].clone(); - let ptr = operands[1].clone(); + let ptr = operands[0].clone(); + let len = operands[1].clone(); let block = self.blocks.pop().unwrap(); let var = self.var(); self.blocks .last_mut() .unwrap() .push_str(&format!( - "{var} <- mapM (\\bg_base_ptr -> do {{\n{};\nreturn bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", + "{var} <- mapM (\\bg_base_ptr -> do {{\n{}return bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", block.to_string() )); results.push(var); @@ -810,7 +822,7 @@ impl<'a> Bindgen for HsFunc<'a> { .zip(blocks) .map(|(case, block)| { format!( - "{}{}{} -> do {{\n{}; return bg_v }}", + "{}{}{} -> do {{\n{}return bg_v }}", upper_ident(name), upper_ident(&case.name), if case.ty.is_some() { " bg_payload" } else { "" }, @@ -821,7 +833,7 @@ impl<'a> Bindgen for HsFunc<'a> { .join(";\n"); let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- (case {} of {{\n{cases} }});\n", + "({}) <- case {} of {{\n{cases} }};\n", vars.join(", "), operands[0] )); @@ -836,7 +848,7 @@ impl<'a> Bindgen for HsFunc<'a> { .zip(blocks) .map(|((i, case), block)| { format!( - "{i} -> do {{ {};\n(return ({}{} bg_v))\n}}\n", + "{i} -> do {{ {}\n(return ({}{} bg_v)) }}", block.to_string(), upper_ident(name), upper_ident(&case.name), @@ -846,7 +858,7 @@ impl<'a> Bindgen for HsFunc<'a> { .join(";\n"); let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (case {} of {{\n{cases} }})", + "{var} <- case {} of {{\n{cases} }};\n", operands[0] )); results.push(var); @@ -897,7 +909,7 @@ impl<'a> Bindgen for HsFunc<'a> { let none = self.blocks.pop().unwrap().to_string(); let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- case {} of {{\nNothing -> do {{\n{none}\n}};\nJust bg_payload -> do {{\n{some}\n}} }}\n", + "({}) <- case {} of {{\nNothing -> do {{\n{none}\n}};\nJust bg_payload -> do {{\n{some}\n}} }};\n", vars.join(", "), operands[0] )); @@ -908,7 +920,7 @@ impl<'a> Bindgen for HsFunc<'a> { let none = self.blocks.pop().unwrap().to_string(); let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (case {} of\n0 -> (do {{\n{none};\nreturn Nothing\n}});\n_ -> (do {{\n{some});\nreturn (Just bg_v)\n}})))", + "{var} <- case {} of {{\n0 -> (do {{\n{none}return Nothing\n}});\n_ -> (do {{\n{some}return (Just bg_v)\n}}) }};\n", operands[0] )); results.push(var); @@ -922,7 +934,7 @@ impl<'a> Bindgen for HsFunc<'a> { let err = self.blocks.pop().unwrap().to_string(); let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}\n}};\nRight bg_payload -> do {{\n{ok}\n}} }}\n", + "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}\n}};\nRight bg_payload -> do {{\n{ok}\n}}\n}};\n", vars.join(", "), operands[0] )); @@ -933,7 +945,7 @@ impl<'a> Bindgen for HsFunc<'a> { let ok = self.blocks.pop().unwrap().to_string(); let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (case {} of\n0 -> (do {{\n{ok};\nreturn (Right bg_v)\n}});\n_ -> (do {{\n{err});\nreturn (Left bg_v)\n}})))", + "{var} <- case {} of {{\n0 -> (do {{\n{ok}return (Right bg_v)\n}});\n_ -> (do {{\n{err}return (Left bg_v)\n}}) }};\n", operands[0] )); results.push(var); @@ -982,8 +994,12 @@ impl<'a> Bindgen for HsFunc<'a> { } fn return_pointer(&mut self, size: usize, align: usize) -> Self::Operand { - self.blocks.last_mut().unwrap().push_str(&format!( - "bg_ret_ptr <- (callocBytes :: Int -> IO (Ptr Word8)) {size};\n" + let current_block = self.blocks.last_mut().unwrap(); + current_block.push_str(&format!( + "bg_tmp <- (callocBytes :: Int -> IO (Ptr Word8)) {size};\n" + )); + current_block.push_str(&format!( + "bg_ret_ptr <- return ((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr bg_tmp));\n" )); "bg_ret_ptr".to_owned() } @@ -996,7 +1012,7 @@ impl<'a> Bindgen for HsFunc<'a> { self.blocks .last_mut() .unwrap() - .push_str(&format!("bg_v <- return ({})", operand.join(", "))); + .push_str(&format!("bg_v <- return ({});\n", operand.join(", "))); } fn sizes(&self) -> &SizeAlign { @@ -1275,7 +1291,7 @@ fn func_name_foreign(func: &Function, ns: &str, dir: Direction) -> String { fn func_name(func: &Function, ns: Option<&str>) -> String { if let Some(ns) = ns { - format!("{}.Exports.{}", upper_ident(ns), lower_ident(&func.name)) + format!("{}.{}", upper_ident(ns), lower_ident(&func.name)) } else { lower_ident(&func.name) } @@ -1321,7 +1337,7 @@ fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { } else { None }; - let ns = ns.map(|n| format!("Types.{}", upper_ident(&n))); + let ns = ns.map(|n| format!("{}.Types", upper_ident(&n))); if let Some(name) = &ty.name { if let Some(ns) = ns { format!("{ns}.{}", upper_ident(name)) From 7fc029787f69a12bb3b8c2c55a2dff8f0a45263f Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Sun, 30 Jun 2024 12:32:36 +0200 Subject: [PATCH 4/7] tests --- Cargo.lock | 1 + crates/haskell/Cargo.toml | 3 + crates/haskell/src/lib.rs | 158 ++++++++++++++++++++++++-------- crates/haskell/tests/codegen.rs | 39 ++++++++ 4 files changed, 165 insertions(+), 36 deletions(-) create mode 100644 crates/haskell/tests/codegen.rs diff --git a/Cargo.lock b/Cargo.lock index 048b5a562..0b5eae83b 100644 --- a/Cargo.lock +++ b/Cargo.lock @@ -2418,6 +2418,7 @@ dependencies = [ "clap", "heck 0.5.0", "indexmap", + "test-helpers", "wit-bindgen-core", "wit-parser 0.209.0", ] diff --git a/crates/haskell/Cargo.toml b/crates/haskell/Cargo.toml index 2dae3bead..3911f2b38 100644 --- a/crates/haskell/Cargo.toml +++ b/crates/haskell/Cargo.toml @@ -21,3 +21,6 @@ anyhow = { workspace = true } heck = { workspace = true } clap = { workspace = true, optional = true } indexmap = { workspace = true } + +[dev-dependencies] +test-helpers = { path = '../test-helpers' } diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index 8bac3a2b6..17ade4ff2 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -2,9 +2,8 @@ use abi::{AbiVariant, WasmType}; use anyhow::Result; use heck::{ToLowerCamelCase as _, ToSnakeCase as _, ToUpperCamelCase as _}; use indexmap::{IndexMap, IndexSet}; -use wit_bindgen_core; use wit_bindgen_core::abi::{call, Bindgen, Bitcast, Instruction, LiftLower}; -use wit_bindgen_core::{Direction, Files, Source, WorldGenerator}; +use wit_bindgen_core::{dealias, Direction, Files, Source, WorldGenerator}; use wit_parser::*; @@ -25,6 +24,7 @@ struct Module { funcs_imp: Source, funcs_exp: Source, tydefs: IndexSet, + user: Source, docs: Option, imports_exports: bool, } @@ -109,6 +109,7 @@ impl WorldGenerator for Haskell { &iname, AbiVariant::GuestExport, )); + module.user.push_str(&gen_func_placeholder(resolve, func)); self.c_header .push_str(&gen_func_c(resolve, func, &iname, Direction::Export)); } @@ -173,6 +174,7 @@ impl WorldGenerator for Haskell { AbiVariant::GuestExport, )); module.funcs_exp.push_str("\n"); + module.user.push_str(&gen_func_placeholder(resolve, func)); self.c_header .push_str(&gen_func_c(resolve, func, &world.name, Direction::Export)); } @@ -242,6 +244,16 @@ impl WorldGenerator for Haskell { ); files.push(&format!("{}/Types.hs", name.replace('.', "/")), &contents); } + let user = gen_module( + &name, + &module.user, + ModuleKind::User { + imports_types: !module.tydefs.is_empty(), + imports_imports: !module.funcs_imp.is_empty(), + }, + &module.docs, + ); + files.push(&format!("{name}.hs"), &user); } let c_header = format!("#include \n\n{}", self.c_header); files.push("bg_foreign.h", c_header.as_bytes()); @@ -250,9 +262,17 @@ impl WorldGenerator for Haskell { } enum ModuleKind { - Imports { imports_types: bool }, - Exports { imports_types: bool }, + Imports { + imports_types: bool, + }, + Exports { + imports_types: bool, + }, Types, + User { + imports_types: bool, + imports_imports: bool, + }, } fn gen_module(name: &str, src: &str, module_kind: ModuleKind, docs: &Option) -> Vec { @@ -260,6 +280,7 @@ fn gen_module(name: &str, src: &str, module_kind: ModuleKind, docs: &Option format!("{name}.Imports"), ModuleKind::Exports { .. } => format!("{name}.Exports"), ModuleKind::Types => format!("{name}.Types"), + ModuleKind::User { .. } => name.to_owned(), }; format!( "\ @@ -271,14 +292,16 @@ module {module_name} where import Data.Word; import Data.Int; +import Data.Char; import Data.Bits; -import Data.Text; +import Data.Text hiding (length, unpack); import Data.Text.Encoding; -import Data.ByteString; +import Data.ByteString hiding (length); import GHC.Float; import Foreign.Ptr; import Foreign.Storable; import Foreign.Marshal.Array; +import Foreign.Marshal.Alloc; {} {} @@ -291,22 +314,26 @@ import Foreign.Marshal.Array; } else { "".to_owned() }, - if matches!( - module_kind, + match module_kind { ModuleKind::Imports { - imports_types: true - } | ModuleKind::Exports { - imports_types: true + imports_types: true, } - ) { - format!("import {name}.Types;\n") - } else { - "".to_owned() + | ModuleKind::Exports { + imports_types: true, + } + | ModuleKind::User { + imports_types: true, + .. + } => format!("import {name}.Types;\n"), + _ => "".to_owned(), }, - if matches!(module_kind, ModuleKind::Exports { .. }) { - format!("import qualified {name};\n") - } else { - "".to_owned() + match module_kind { + ModuleKind::Exports { .. } => format!("import qualified {name};\n"), + ModuleKind::User { + imports_imports: true, + .. + } => format!("import qualified {name}.Imports;\n"), + _ => "".to_owned(), }, src.to_string() ) @@ -661,9 +688,9 @@ impl<'a> Bindgen for HsFunc<'a> { let ptr = self.var(); let len = self.var(); let current_block = self.blocks.last_mut().unwrap(); - current_block.push_str(&format!("{len} <- length {list};\n")); + current_block.push_str(&format!("let {{ {len} = length {list} }};\n")); current_block.push_str(&format!( - "{ptr} <- (callocBytes :: Int -> IO (Ptr [{}])) {len};\n", + "{ptr} <- (callocBytes :: Int -> IO (Ptr ({}))) {len};\n", ty_name(resolve, false, element) )); current_block.push_str(&format!("pokeArray {ptr} {list};\n",)); @@ -673,14 +700,14 @@ impl<'a> Bindgen for HsFunc<'a> { ]); } Instruction::StringLower { realloc } => { - let ptr: String = self.var(); + let ptr = self.var(); let len = self.var(); let current_block = self.blocks.last_mut().unwrap(); current_block.push_str(&format!( - "bg_tmp <- return (unpack (encodeUtf8 {}));\n", + "let {{ bg_tmp = unpack (encodeUtf8 {}) }};\n", operands[0] )); - current_block.push_str(&format!("{len} <- return (length bg_tmp);\n")); + current_block.push_str(&format!("let {{ {len} = length bg_tmp }};\n")); current_block.push_str(&format!( "{ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) {len};\n" )); @@ -697,7 +724,7 @@ impl<'a> Bindgen for HsFunc<'a> { let list_len = self.var(); let list_ptr = self.var(); let current_block = self.blocks.last_mut().unwrap(); - current_block.push_str(&format!("{list_len} <- length {list};\n",)); + current_block.push_str(&format!("let {{ {list_len} = length {list} }};\n",)); current_block.push_str(&format!( "{list_ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) ({list_len} * {});\n", size @@ -723,11 +750,11 @@ impl<'a> Bindgen for HsFunc<'a> { } Instruction::StringLift => { let ptr = operands[0].clone(); - let len: String = operands[1].clone(); + let len = operands[1].clone(); let var = self.var(); let current_block = self.blocks.last_mut().unwrap(); current_block.push_str(&format!("bg_tmp <- (peekArray :: Int -> Ptr Word8 -> IO [Word8]) (fromIntegral {len}) (wordPtrToPtr {ptr});\n")); - current_block.push_str(&format!("{var} <- return (decodeUtf8 (pack bg_tmp));\n")); + current_block.push_str(&format!("let {{ {var} = decodeUtf8 (pack bg_tmp) }};\n")); results.push(var); } Instruction::ListLift { element, ty } => { @@ -999,7 +1026,7 @@ impl<'a> Bindgen for HsFunc<'a> { "bg_tmp <- (callocBytes :: Int -> IO (Ptr Word8)) {size};\n" )); current_block.push_str(&format!( - "bg_ret_ptr <- return ((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr bg_tmp));\n" + "let {{ bg_ret_ptr = (fromIntegral :: WordPtr -> Word32) (ptrToWordPtr bg_tmp) }};\n" )); "bg_ret_ptr".to_owned() } @@ -1012,14 +1039,14 @@ impl<'a> Bindgen for HsFunc<'a> { self.blocks .last_mut() .unwrap() - .push_str(&format!("bg_v <- return ({});\n", operand.join(", "))); + .push_str(&format!("let {{ bg_v = ({}) }};\n", operand.join(", "))); } fn sizes(&self) -> &SizeAlign { &self.size_align } - fn is_list_canonical(&self, _resolve: &Resolve, element: &Type) -> bool { + fn is_list_canonical(&self, resolve: &Resolve, element: &Type) -> bool { match element { Type::U8 | Type::U16 @@ -1032,7 +1059,18 @@ impl<'a> Bindgen for HsFunc<'a> { | Type::F32 | Type::F64 | Type::Char => true, - Type::Bool | Type::String | Type::Id(_) => false, + Type::Id(id) => { + let ty = resolve + .types + .get(dealias(resolve, *id)) + .map(|ty| ty.kind.clone()); + if let Some(TypeDefKind::Type(ty)) = ty { + self.is_list_canonical(resolve, &ty) + } else { + false + } + } + Type::Bool | Type::String => false, } } } @@ -1043,7 +1081,7 @@ fn bitcast(op: &String, cast: &Bitcast) -> String { Bitcast::F64ToI64 => format!("(castDoubleToWord64 {op})"), Bitcast::I32ToI64 => format!("((fromIntegral :: Word32 -> Word64) {op})"), Bitcast::F32ToI64 => { - format!("((fromIntegral :: Word32 -> Word64) (castFloatToWord32) {op})") + format!("((fromIntegral :: Word32 -> Word64) (castFloatToWord32 {op}))") } Bitcast::I32ToF32 => format!("(castWord32ToFloat {op})"), Bitcast::I64ToF64 => format!("(castWord64ToDouble {op})"), @@ -1125,7 +1163,7 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { size_align, variant: AbiVariant::GuestImport, }; - src.push('\n'); + src.push_str(";\n"); src.push_str(&format!( "{} {} = ", func_name(func, None), @@ -1160,7 +1198,7 @@ fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVaria &(if variant == AbiVariant::GuestExport { format!("foreign export capi \"{name_foreign}\" {name_foreign} :: ") } else { - format!("foreign import capi \"bg_foreign.h {name_foreign}\" {name_foreign} :: ") + format!("foreign import capi \"../bg_foreign.h {name_foreign}\" {name_foreign} :: ") }), ); src.push_str( @@ -1183,6 +1221,7 @@ fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVaria ) }; src.push_str(&results); + src.push_str(";"); if variant == AbiVariant::GuestExport { let mut size_align = SizeAlign::new(AddressSize::Wasm32); size_align.fill(resolve); @@ -1214,8 +1253,50 @@ fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVaria src } +fn gen_func_placeholder(resolve: &Resolve, func: &Function) -> String { + let mut src = String::new(); + let name = lower_ident(&func.name); + src.push_str(&format!("\n{name} :: ")); + for (_, ty) in &func.params { + src.push_str(&ty_name(resolve, false, &ty)); + src.push_str(" -> "); + } + src.push_str("IO "); + match &func.results { + Results::Named(params) => { + src.push_str(&format!( + "({})", + params + .iter() + .map(|(_, ty)| ty_name(resolve, false, ty)) + .collect::>() + .join(", ") + )); + } + Results::Anon(ty) => { + src.push_str(&ty_name(resolve, false, &ty)); + } + } + src.push_str(&format!( + "\n{name} {} = undefined\n", + func.params + .iter() + .map(|(name, _)| lower_ident(name)) + .collect::>() + .join(" ") + )); + src +} + fn gen_func_c(resolve: &Resolve, func: &Function, ns: &str, dir: Direction) -> String { - let sig = resolve.wasm_signature(AbiVariant::GuestImport, func); + let sig = resolve.wasm_signature( + if dir == Direction::Import { + AbiVariant::GuestImport + } else { + AbiVariant::GuestExport + }, + func, + ); let func_name_foreign = func_name_foreign(func, ns, dir); let symbol = func.core_export_name(Some(ns)); let ret_ty = match sig.results.as_slice() { @@ -1255,10 +1336,15 @@ fn gen_func_c(resolve: &Resolve, func: &Function, ns: &str, dir: Direction) -> S __export_name__(\"{symbol}\") )); {ret_ty} {func_name_export}({params}) {{ - return {func_name_foreign}({vars}); + {}{func_name_foreign}({vars}); }} ", + if func.results.len() == 0 { + "" + } else { + "return " + }, ) } } diff --git a/crates/haskell/tests/codegen.rs b/crates/haskell/tests/codegen.rs new file mode 100644 index 000000000..58bed44e7 --- /dev/null +++ b/crates/haskell/tests/codegen.rs @@ -0,0 +1,39 @@ +use std::path::Path; +use std::process::Command; + +use heck::*; + +macro_rules! codegen_test { + ($id:ident $name:tt $test:tt) => { + #[test] + fn $id() { + test_helpers::run_world_codegen_test( + "guest-haskell", + $test.as_ref(), + |resolve, world, files| { + wit_bindgen_haskell::Opts::default() + .build() + .generate(resolve, world, files) + .unwrap() + }, + verify, + ) + } + }; +} + +test_helpers::codegen_tests!(); + +fn verify(dir: &Path, name: &str) { + let name = name.to_upper_camel_case(); + let mut cmd = Command::new("wasm32-wasi-ghc"); + cmd.arg(format!("{name}.hs")); + cmd.arg("-o"); + cmd.arg(format!("{name}.wasm")); + cmd.arg("-no-hs-main"); + cmd.arg("-optl-mexec-model=reactor"); + cmd.arg("-optl-Wl"); + cmd.arg("-rdynamic"); + cmd.current_dir(dir); + test_helpers::run_command(&mut cmd); +} From 623dc896957e6bf6ffc04296bbd7b666f36a0bcb Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Mon, 1 Jul 2024 10:13:13 +0200 Subject: [PATCH 5/7] pointer arithmetic fixes --- crates/haskell/src/lib.rs | 64 ++++++++++++++++++--------------- crates/haskell/tests/codegen.rs | 2 +- 2 files changed, 36 insertions(+), 30 deletions(-) diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index 17ade4ff2..52b0ba28f 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -294,9 +294,9 @@ import Data.Word; import Data.Int; import Data.Char; import Data.Bits; -import Data.Text hiding (length, unpack); +import Data.Text hiding (length, unpack, pack, zip); import Data.Text.Encoding; -import Data.ByteString hiding (length); +import Data.ByteString hiding (length, zip); import GHC.Float; import Foreign.Ptr; import Foreign.Storable; @@ -491,7 +491,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::I32Load { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); @@ -499,14 +499,14 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::I32Load8U { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word8 -> IO Word8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", operands[0] + "{var} <- (peek :: Ptr Word8 -> IO Word8) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(format!("((fromIntegral :: Word8 -> Word32) {var})")); } Instruction::I32Load8S { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Int8 -> IO Int8) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Int8 -> IO Int8) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(format!("((fromIntegral :: Int8 -> Word32) {var})")); @@ -514,7 +514,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::I32Load16U { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word16 -> IO Word16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Word16 -> IO Word16) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(format!("((fromIntegral :: Word16 -> Word32) {var})")); @@ -522,7 +522,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::I32Load16S { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Int16 -> IO Int16) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Int16 -> IO Int16) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(format!("((fromIntegral :: Int16 -> Word32) {var})")); @@ -530,7 +530,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::I64Load { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word64 -> IO Word64) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Word64 -> IO Word64) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); @@ -538,7 +538,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::F32Load { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Float -> IO Float) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Float -> IO Float) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); @@ -546,7 +546,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::F64Load { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Double -> IO Double) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Double -> IO Double) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); @@ -554,7 +554,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::PointerLoad { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); @@ -562,56 +562,56 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::LengthLoad { offset } => { let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr ({} + {offset})));\n", + "{var} <- (peek :: Ptr Word32 -> IO Word32) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset}))));\n", operands[0] )); results.push(var); } Instruction::I32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr 32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Word32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } Instruction::I32Store8 { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word8 -> Word8 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word8) {});\n", + "(poke :: Ptr Word8 -> Word8 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) ((fromIntegral :: Word32 -> Word8) {});\n", operands[1], operands[0] )); } Instruction::I32Store16 { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word16 -> Word16 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) ((fromIntegral :: Word32 -> Word16) {});\n", + "(poke :: Ptr Word16 -> Word16 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) ((fromIntegral :: Word32 -> Word16) {});\n", operands[1], operands[0] )); } Instruction::I64Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word64 -> Word64 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Word64 -> Word64 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } Instruction::F32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Float -> Float -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Float -> Float -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } Instruction::F64Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Double -> Double -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Double -> Double -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } Instruction::PointerStore { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } Instruction::LengthStore { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr ({} + {offset}))) {};\n", + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } @@ -729,12 +729,14 @@ impl<'a> Bindgen for HsFunc<'a> { "{list_ptr} <- (callocBytes :: Int -> IO (Ptr Word8)) ({list_len} * {});\n", size )); + let ptr_as_word32 = + format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {list_ptr}))"); current_block.push_str(&format!( - "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}\n}}) (zip (enumFromThenTo {list_ptr} ({list_ptr} + {size}) ({list_len} * {size} - {size})) {list});\n", + "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}return bg_v\n}}) (zip (enumFromThenTo {ptr_as_word32} ({ptr_as_word32} + {size}) ((fromIntegral {list_len}) * {size} - {size})) {list});\n", block.to_string() )); results.extend([ - format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {list_ptr}))"), + ptr_as_word32, format!("((fromIntegral :: Int -> Word32) {list_len})"), ]); } @@ -744,7 +746,7 @@ impl<'a> Bindgen for HsFunc<'a> { let len = operands[1].clone(); let var = self.var(); self.blocks.last_mut().unwrap().push_str(&format!( - "{var} <- ((peekArray :: Int -> Ptr {ty} -> IO [ty]) (fromIntegral {len}) (wordPtrToPtr {ptr}));\n" + "{var} <- (peekArray :: Int -> Ptr {ty} -> IO [{ty}]) (fromIntegral {len}) (wordPtrToPtr (WordPtr (fromIntegral {ptr})));\n" )); results.push(var); } @@ -753,7 +755,7 @@ impl<'a> Bindgen for HsFunc<'a> { let len = operands[1].clone(); let var = self.var(); let current_block = self.blocks.last_mut().unwrap(); - current_block.push_str(&format!("bg_tmp <- (peekArray :: Int -> Ptr Word8 -> IO [Word8]) (fromIntegral {len}) (wordPtrToPtr {ptr});\n")); + current_block.push_str(&format!("bg_tmp <- (peekArray :: Int -> Ptr Word8 -> IO [Word8]) (fromIntegral {len}) (wordPtrToPtr (WordPtr (fromIntegral {ptr})));\n")); current_block.push_str(&format!("let {{ {var} = decodeUtf8 (pack bg_tmp) }};\n")); results.push(var); } @@ -936,7 +938,7 @@ impl<'a> Bindgen for HsFunc<'a> { let none = self.blocks.pop().unwrap().to_string(); let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- case {} of {{\nNothing -> do {{\n{none}\n}};\nJust bg_payload -> do {{\n{some}\n}} }};\n", + "({}) <- case {} of {{\nNothing -> do {{\n{none}return bg_v\n}};\nJust bg_payload -> do {{\n{some}return bg_v\n}} }};\n", vars.join(", "), operands[0] )); @@ -957,11 +959,11 @@ impl<'a> Bindgen for HsFunc<'a> { ty, results: types, } => { - let ok = self.blocks.pop().unwrap().to_string(); let err = self.blocks.pop().unwrap().to_string(); + let ok = self.blocks.pop().unwrap().to_string(); let vars = self.vars(types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}\n}};\nRight bg_payload -> do {{\n{ok}\n}}\n}};\n", + "({}) <- case {} of {{\nLeft bg_payload -> do {{\n{err}return bg_v\n}};\nRight bg_payload -> do {{\n{ok}return bg_v\n}}\n}};\n", vars.join(", "), operands[0] )); @@ -1143,7 +1145,7 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { } Results::Anon(ty) => { let mut name = ty_name(resolve, false, &ty); - if name.contains(" ") && !name.starts_with("(") && !name.starts_with("[") { + if name.contains(' ') && !name.starts_with('(') && !name.starts_with('[') { name = format!("({name})"); } src.push_str(&name); @@ -1274,7 +1276,11 @@ fn gen_func_placeholder(resolve: &Resolve, func: &Function) -> String { )); } Results::Anon(ty) => { - src.push_str(&ty_name(resolve, false, &ty)); + let mut name = ty_name(resolve, false, &ty); + if name.contains(' ') && !name.starts_with('(') && !name.starts_with('[') { + name = format!("({})", name); + } + src.push_str(&name); } } src.push_str(&format!( diff --git a/crates/haskell/tests/codegen.rs b/crates/haskell/tests/codegen.rs index 58bed44e7..1fa8ccdfd 100644 --- a/crates/haskell/tests/codegen.rs +++ b/crates/haskell/tests/codegen.rs @@ -27,7 +27,7 @@ test_helpers::codegen_tests!(); fn verify(dir: &Path, name: &str) { let name = name.to_upper_camel_case(); let mut cmd = Command::new("wasm32-wasi-ghc"); - cmd.arg(format!("{name}.hs")); + cmd.arg(format!("{name}/Exports.hs")); cmd.arg("-o"); cmd.arg(format!("{name}.wasm")); cmd.arg("-no-hs-main"); From d3f3ff4c61bc60484c15e98f6af7a9ba922ae918 Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Thu, 4 Jul 2024 11:35:04 +0200 Subject: [PATCH 6/7] post return --- crates/haskell/src/lib.rs | 199 +++++++++++++++++++++++++++++++++++--- 1 file changed, 183 insertions(+), 16 deletions(-) diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index 52b0ba28f..c83899a1a 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -2,7 +2,9 @@ use abi::{AbiVariant, WasmType}; use anyhow::Result; use heck::{ToLowerCamelCase as _, ToSnakeCase as _, ToUpperCamelCase as _}; use indexmap::{IndexMap, IndexSet}; -use wit_bindgen_core::abi::{call, Bindgen, Bitcast, Instruction, LiftLower}; +use wit_bindgen_core::abi::{ + call, guest_export_needs_post_return, post_return, Bindgen, Bitcast, Instruction, LiftLower, +}; use wit_bindgen_core::{dealias, Direction, Files, Source, WorldGenerator}; use wit_parser::*; @@ -110,6 +112,14 @@ impl WorldGenerator for Haskell { AbiVariant::GuestExport, )); module.user.push_str(&gen_func_placeholder(resolve, func)); + if guest_export_needs_post_return(resolve, func) { + module + .funcs_exp + .push_str(&gen_func_post_return(resolve, func, &iname)); + module.funcs_exp.push_str("\n"); + self.c_header + .push_str(&gen_func_c_post_return(resolve, func, &iname)); + } self.c_header .push_str(&gen_func_c(resolve, func, &iname, Direction::Export)); } @@ -175,6 +185,14 @@ impl WorldGenerator for Haskell { )); module.funcs_exp.push_str("\n"); module.user.push_str(&gen_func_placeholder(resolve, func)); + if guest_export_needs_post_return(resolve, func) { + module + .funcs_exp + .push_str(&gen_func_post_return(resolve, func, &world.name)); + module.funcs_exp.push_str("\n"); + self.c_header + .push_str(&gen_func_c_post_return(resolve, func, &world.name)); + } self.c_header .push_str(&gen_func_c(resolve, func, &world.name, Direction::Export)); } @@ -569,7 +587,7 @@ impl<'a> Bindgen for HsFunc<'a> { } Instruction::I32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", + "(poke :: Ptr Word32 -> Word 32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } @@ -732,7 +750,7 @@ impl<'a> Bindgen for HsFunc<'a> { let ptr_as_word32 = format!("((fromIntegral :: WordPtr -> Word32) (ptrToWordPtr {list_ptr}))"); current_block.push_str(&format!( - "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}return bg_v\n}}) (zip (enumFromThenTo {ptr_as_word32} ({ptr_as_word32} + {size}) ((fromIntegral {list_len}) * {size} - {size})) {list});\n", + "mapM_ (\\(bg_base_ptr, bg_elem) -> do {{\n{}return bg_v\n}}) (zip (if {list_len} == 0 then [] else enumFromThenTo {ptr_as_word32} ({ptr_as_word32} + {size}) ((fromIntegral {list_len}) * {size} + {ptr_as_word32} - {size})) {list});\n", block.to_string() )); results.extend([ @@ -769,7 +787,7 @@ impl<'a> Bindgen for HsFunc<'a> { .last_mut() .unwrap() .push_str(&format!( - "{var} <- mapM (\\bg_base_ptr -> do {{\n{}return bg_v\n}}) (enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} - {size}));\n", + "{var} <- mapM (\\bg_base_ptr -> do {{\n{}return bg_v\n}}) (if {len} == 0 then [] else enumFromThenTo {ptr} ({ptr} + {size}) ({len} * {size} + {ptr} - {size}));\n", block.to_string() )); results.push(var); @@ -806,7 +824,7 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::TupleLower { tuple, ty } => { let fields = self.vars(tuple.types.len()); self.blocks.last_mut().unwrap().push_str(&format!( - "({}) <- return ({});\n", + "let {{ ({}) = {} }};\n", fields.join(", "), operands[0] )); @@ -815,7 +833,30 @@ impl<'a> Bindgen for HsFunc<'a> { Instruction::TupleLift { tuple, ty } => { results.push(format!("({})", operands.join(", "))); } - Instruction::FlagsLower { flags, name, ty } => todo!(), + Instruction::FlagsLower { flags, name, ty } => match flags.repr() { + FlagsRepr::U8 | FlagsRepr::U16 | FlagsRepr::U32(1) => { + let rep_ty = match flags.repr() { + FlagsRepr::U8 => "Word8", + FlagsRepr::U16 => "Word16", + FlagsRepr::U32(_) => "Word32", + }; + results.push(format!( + "((0 :: {rep_ty}) .|. ({}))", + flags + .flags + .iter() + .enumerate() + .map(|(i, flag)| { + let field = lower_ident(&[*name, &flag.name].join("-")); + let mask = 1 << i; + format!("(if ({field} {}) then ({mask} :: {rep_ty}) else (0 :: {rep_ty}))", operands[0]) + }) + .collect::>() + .join(" .|. ") + )) + } + _ => todo!(), + }, Instruction::FlagsLift { flags, name, ty } => { results.push(format!( "({} {{ {} }})", @@ -826,9 +867,10 @@ impl<'a> Bindgen for HsFunc<'a> { .enumerate() .map(|(i, flag)| { format!( - "{} = ((shiftR {} {i}) (.&.) 1) == 1)", + "{} = ({} .&. {}) /= 0", lower_ident(&format!("{name}-{}", flag.name)), - operands[0 / 32] + operands[0 / 32], + 1 << i, ) }) .collect::>() @@ -877,7 +919,12 @@ impl<'a> Bindgen for HsFunc<'a> { .zip(blocks) .map(|((i, case), block)| { format!( - "{i} -> do {{ {}\n(return ({}{} bg_v)) }}", + "{} -> do {{ {}\n(return ({}{} bg_v)) }}", + if i == variant.cases.len() - 1 { + "_".to_owned() + } else { + i.to_string() + }, block.to_string(), upper_ident(name), upper_ident(&case.name), @@ -1016,9 +1063,49 @@ impl<'a> Bindgen for HsFunc<'a> { operands[0] )); } - Instruction::GuestDeallocateString => todo!(), - Instruction::GuestDeallocateList { element } => todo!(), - Instruction::GuestDeallocateVariant { blocks } => todo!(), + Instruction::GuestDeallocateString => { + self.blocks.last_mut().unwrap().push_str(&format!( + "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {}));\n", + operands[0] + )); + } + Instruction::GuestDeallocateList { element } => { + let block = self.blocks.pop().unwrap(); + let current_block = self.blocks.last_mut().unwrap(); + let size = self.size_align.size(element); + let ptr = &operands[0]; + let len = &operands[1]; + current_block.push_str(&format!( + "mapM_ (\\bg_base_ptr -> do {{\n{}return bg_v\n}}) (if {len} == 0 then [] else enumFromThenTo {ptr} ({ptr} + {size}) ((fromIntegral {len}) * {size} + {ptr} - {size}));\n", + block.to_string() + )); + current_block + .push_str("(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {ptr}));\n"); + } + Instruction::GuestDeallocateVariant { + blocks: blocks_count, + } => { + let blocks = self.blocks.drain(self.blocks.len() - blocks_count..); + let cases = blocks + .enumerate() + .map(|(i, block)| { + format!( + "{} -> do {{\n{}\n}}", + if i == blocks_count - 1 { + "_".to_owned() + } else { + i.to_string() + }, + block.to_string() + ) + }) + .collect::>(); + self.blocks.last_mut().unwrap().push_str(&format!( + "case {} of {{{}}};\n", + operands[0], + cases.join(";\n") + )); + } } } @@ -1154,7 +1241,7 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { let mut size_align = SizeAlign::new(AddressSize::Wasm32); size_align.fill(resolve); let mut bindgen = HsFunc { - dual_func: &func_name_foreign(func, ns, Direction::Import), + dual_func: &func_name_foreign(func, ns, Direction::Import, false), params: func .params .iter() @@ -1195,6 +1282,7 @@ fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVaria } else { Direction::Import }, + false, ); src.push_str( &(if variant == AbiVariant::GuestExport { @@ -1255,10 +1343,55 @@ fn gen_func_core(resolve: &Resolve, func: &Function, ns: &str, variant: AbiVaria src } +fn gen_func_post_return(resolve: &Resolve, func: &Function, ns: &str) -> String { + let mut src = String::new(); + src.push('\n'); + let name_foreign = func_name_foreign(func, ns, Direction::Export, true); + let params = resolve + .wasm_signature(AbiVariant::GuestExport, func) + .results; + src.push_str(&format!( + "foreign export capi \"{name_foreign}\" {name_foreign} :: {} -> IO ();\n", + params + .iter() + .map(|ty| core_ty_name(*ty)) + .collect::>() + .join(" -> ") + )); + let params = params + .iter() + .enumerate() + .map(|(i, _)| format!("bg_p{i}")) + .collect::>(); + src.push_str(&format!("{name_foreign} {} = ", params.join(" "))); + let mut size_align = SizeAlign::new(AddressSize::Wasm32); + size_align.fill(resolve); + let mut bindgen = HsFunc { + dual_func: &name_foreign, + params, + blocks: vec![Source::default()], + var_count: 0, + size_align, + variant: AbiVariant::GuestExport, + }; + post_return(resolve, func, &mut bindgen); + src.push_str(&format!("do {{\n{}\n}};\n", &bindgen.blocks[0].to_string())); + src +} + fn gen_func_placeholder(resolve: &Resolve, func: &Function) -> String { let mut src = String::new(); + src.push('\n'); let name = lower_ident(&func.name); - src.push_str(&format!("\n{name} :: ")); + if let Some(docs) = &func.docs.contents { + src.push_str( + &docs + .lines() + .map(|line| format!("-- {line}\n")) + .collect::(), + ); + } + src.push_str(&format!("{name} :: ")); for (_, ty) in &func.params { src.push_str(&ty_name(resolve, false, &ty)); src.push_str(" -> "); @@ -1303,7 +1436,7 @@ fn gen_func_c(resolve: &Resolve, func: &Function, ns: &str, dir: Direction) -> S }, func, ); - let func_name_foreign = func_name_foreign(func, ns, dir); + let func_name_foreign = func_name_foreign(func, ns, dir, false); let symbol = func.core_export_name(Some(ns)); let ret_ty = match sig.results.as_slice() { [] => "void".to_owned(), @@ -1355,6 +1488,38 @@ fn gen_func_c(resolve: &Resolve, func: &Function, ns: &str, dir: Direction) -> S } } +fn gen_func_c_post_return(resolve: &Resolve, func: &Function, ns: &str) -> String { + let func_name_foreign = func_name_foreign(func, ns, Direction::Export, true); + let func_name_export = format!("cabi_post_{}", [ns, &func.name].join("-").to_snake_case()); + let symbol = format!("cabi_post_{}", func.core_export_name(Some(ns))); + let sig = resolve.wasm_signature(AbiVariant::GuestExport, func); + let params = sig + .results + .iter() + .enumerate() + .map(|(i, ty)| format!("{} bg_p{i}", ty_name_c(ty))) + .collect::>() + .join(", "); + let vars = sig + .results + .iter() + .enumerate() + .map(|(i, _)| format!("bg_p{i}")) + .collect::>() + .join(", "); + format!( + "\ +void {func_name_export}({params}) __attribute__(( + __export_name__(\"{symbol}\") +)); +void {func_name_export}({params}) {{ + {func_name_foreign}({vars}); +}} + +" + ) +} + fn ty_name_c(ty: &WasmType) -> String { match ty { WasmType::I32 => "uint32_t".to_owned(), @@ -1367,11 +1532,13 @@ fn ty_name_c(ty: &WasmType) -> String { } } -fn func_name_foreign(func: &Function, ns: &str, dir: Direction) -> String { +fn func_name_foreign(func: &Function, ns: &str, dir: Direction, post_return: bool) -> String { format!( "bg_fn_{}_{}_{}", if dir == Direction::Import { "imp" + } else if post_return { + "post" } else { "exp" }, From c979352462f901e2a704c8f81637faf14ae4d518 Mon Sep 17 00:00:00 2001 From: primoly <168267431+primoly@users.noreply.github.com> Date: Sat, 6 Jul 2024 17:12:21 +0200 Subject: [PATCH 7/7] more types and handles --- crates/haskell/src/lib.rs | 147 +++++++++++++++++++++++++------------- 1 file changed, 98 insertions(+), 49 deletions(-) diff --git a/crates/haskell/src/lib.rs b/crates/haskell/src/lib.rs index c83899a1a..a375ace4b 100644 --- a/crates/haskell/src/lib.rs +++ b/crates/haskell/src/lib.rs @@ -39,6 +39,10 @@ pub struct Haskell { } impl WorldGenerator for Haskell { + fn preprocess(&mut self, resolve: &Resolve, world: WorldId) { + self.modules + .insert(resolve.worlds[world].name.clone(), Module::default()); + } fn import_interface( &mut self, resolve: &Resolve, @@ -237,7 +241,7 @@ impl WorldGenerator for Haskell { ); files.push(&format!("{}/Imports.hs", name.replace('.', "/")), &contents); } - if !module.funcs_exp.is_empty() { + { let contents = gen_module( &name, &module.funcs_exp, @@ -394,7 +398,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { TypeDefKind::Record(record) => { let record_name = upper_ident(name); src.push_str(&format!( - "data {record_name} = {record_name} {{ {} }};\n", + "data {record_name} = {record_name} {{ {} }} deriving (Eq, Show);\n", record .fields .iter() @@ -402,7 +406,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { format!( "{} :: {}", lower_ident(&[name, &field.name].join("-")), - ty_name(resolve, false, &field.ty) + ty_name(resolve, false, &field.ty, false) ) }) .collect::>() @@ -412,14 +416,13 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { TypeDefKind::Resource => { let resource_name = upper_ident(name); src.push_str(&format!( - "newtype {resource_name} = {resource_name} Word32;\n" + "newtype {resource_name} = {resource_name} Word32 deriving (Eq, Show);\n" )); } - TypeDefKind::Handle(_) => todo!(), TypeDefKind::Flags(flags) => { let flags_name = upper_ident(name); src.push_str(&format!( - "data {flags_name} = {flags_name} {{ {} }};\n", + "data {flags_name} = {flags_name} {{ {} }} deriving (Eq, Show);\n", flags .flags .iter() @@ -428,7 +431,6 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { .join(", ") )); } - TypeDefKind::Tuple(_) => todo!(), TypeDefKind::Variant(var) => { let cases = var .cases @@ -438,7 +440,7 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { "{} {}", upper_ident(&[name, &case.name].join("-")), if let Some(ty) = case.ty { - ty_name(resolve, false, &ty) + ty_name(resolve, false, &ty, true) } else { "".to_owned() } @@ -446,7 +448,10 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { }) .collect::>() .join(" | "); - src.push_str(&format!("data {} = {cases};\n", upper_ident(name))) + src.push_str(&format!( + "data {} = {cases} deriving (Eq, Show);\n", + upper_ident(name) + )) } TypeDefKind::Enum(enu) => { let cases = enu @@ -455,21 +460,23 @@ fn gen_typedef(resolve: &Resolve, name: &str, id: TypeId) -> String { .map(|case| upper_ident(&[name, &case.name].join("-"))) .collect::>() .join(" | "); - src.push_str(&format!("data {} = {cases};\n", upper_ident(name))) + src.push_str(&format!( + "data {} = {cases} deriving (Eq, Show);\n", + upper_ident(name) + )) } - TypeDefKind::Option(_) => todo!(), - TypeDefKind::Result(_) => todo!(), - TypeDefKind::List(_) => todo!(), - TypeDefKind::Future(_) => todo!(), - TypeDefKind::Stream(_) => todo!(), TypeDefKind::Type(ty) => { src.push_str(&format!( "type {} = {};\n", upper_ident(name), - ty_name(resolve, false, ty) + ty_name(resolve, false, ty, false) )); } - TypeDefKind::Unknown => todo!(), + _ => src.push_str(&format!( + "type {} = {};\n", + upper_ident(name), + ty_name(resolve, false, &Type::Id(id), false) + )), } src } @@ -587,7 +594,7 @@ impl<'a> Bindgen for HsFunc<'a> { } Instruction::I32Store { offset } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(poke :: Ptr Word32 -> Word 32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", + "(poke :: Ptr Word32 -> Word32 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral ({} + {offset})))) {};\n", operands[1], operands[0] )); } @@ -709,7 +716,7 @@ impl<'a> Bindgen for HsFunc<'a> { current_block.push_str(&format!("let {{ {len} = length {list} }};\n")); current_block.push_str(&format!( "{ptr} <- (callocBytes :: Int -> IO (Ptr ({}))) {len};\n", - ty_name(resolve, false, element) + ty_name(resolve, false, element, false) )); current_block.push_str(&format!("pokeArray {ptr} {list};\n",)); results.extend([ @@ -759,7 +766,7 @@ impl<'a> Bindgen for HsFunc<'a> { ]); } Instruction::ListCanonLift { element, ty } => { - let ty = ty_name(resolve, false, element); + let ty = ty_name(resolve, false, element, false); let ptr = operands[0].clone(); let len = operands[1].clone(); let var = self.var(); @@ -819,8 +826,42 @@ impl<'a> Bindgen for HsFunc<'a> { .join(", "); results.push(format!("({} {{ {} }})", upper_ident(name), fields)); } - Instruction::HandleLower { handle, name, ty } => todo!(), - Instruction::HandleLift { handle, name, ty } => todo!(), + Instruction::HandleLower { + handle: Handle::Own(_), + name, + ty, + } => { + results.push(format!( + "(case {} of {} bg_v -> bg_v)", + operands[0], + upper_ident(name) + )); + } + Instruction::HandleLower { + handle: Handle::Borrow(_), + name, + ty, + } => { + results.push(format!( + "(case {} of {} bg_v -> bg_v)", + operands[0], + upper_ident(name) + )); + } + Instruction::HandleLift { + handle: Handle::Own(_), + name, + ty, + } => { + results.push(format!("({} {})", upper_ident(name), operands[0])); + } + Instruction::HandleLift { + handle: Handle::Borrow(_), + name, + ty, + } => { + results.push(format!("({} {})", upper_ident(name), operands[0])); + } Instruction::TupleLower { tuple, ty } => { let fields = self.vars(tuple.types.len()); self.blocks.last_mut().unwrap().push_str(&format!( @@ -1059,13 +1100,13 @@ impl<'a> Bindgen for HsFunc<'a> { } => todo!(), Instruction::GuestDeallocate { size, align } => { self.blocks.last_mut().unwrap().push_str(&format!( - "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {}));\n", + "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral {})));\n", operands[0] )); } Instruction::GuestDeallocateString => { self.blocks.last_mut().unwrap().push_str(&format!( - "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {}));\n", + "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral {})));\n", operands[0] )); } @@ -1079,8 +1120,9 @@ impl<'a> Bindgen for HsFunc<'a> { "mapM_ (\\bg_base_ptr -> do {{\n{}return bg_v\n}}) (if {len} == 0 then [] else enumFromThenTo {ptr} ({ptr} + {size}) ((fromIntegral {len}) * {size} + {ptr} - {size}));\n", block.to_string() )); - current_block - .push_str("(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr {ptr}));\n"); + current_block.push_str(&format!( + "(free :: Ptr Word8 -> IO ()) (wordPtrToPtr (WordPtr (fromIntegral {ptr})));\n" + )); } Instruction::GuestDeallocateVariant { blocks: blocks_count, @@ -1090,7 +1132,7 @@ impl<'a> Bindgen for HsFunc<'a> { .enumerate() .map(|(i, block)| { format!( - "{} -> do {{\n{}\n}}", + "{} -> do {{\n{}\nreturn bg_v\n}}", if i == blocks_count - 1 { "_".to_owned() } else { @@ -1214,7 +1256,7 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { &func .params .iter() - .map(|(_name, ty)| format!("{} ->", ty_name(resolve, false, ty))) + .map(|(_name, ty)| format!("{} ->", ty_name(resolve, false, ty, false))) .collect::>() .join(" "), ); @@ -1225,16 +1267,13 @@ fn gen_func(resolve: &Resolve, func: &Function, ns: &str) -> String { "({})", results .iter() - .map(|(_name, ty)| ty_name(resolve, false, ty)) + .map(|(_name, ty)| ty_name(resolve, false, ty, false)) .collect::>() .join(", ") )); } Results::Anon(ty) => { - let mut name = ty_name(resolve, false, &ty); - if name.contains(' ') && !name.starts_with('(') && !name.starts_with('[') { - name = format!("({name})"); - } + let name = ty_name(resolve, false, &ty, true); src.push_str(&name); } } @@ -1393,7 +1432,7 @@ fn gen_func_placeholder(resolve: &Resolve, func: &Function) -> String { } src.push_str(&format!("{name} :: ")); for (_, ty) in &func.params { - src.push_str(&ty_name(resolve, false, &ty)); + src.push_str(&ty_name(resolve, false, &ty, false)); src.push_str(" -> "); } src.push_str("IO "); @@ -1403,16 +1442,13 @@ fn gen_func_placeholder(resolve: &Resolve, func: &Function) -> String { "({})", params .iter() - .map(|(_, ty)| ty_name(resolve, false, ty)) + .map(|(_, ty)| ty_name(resolve, false, ty, false)) .collect::>() .join(", ") )); } Results::Anon(ty) => { - let mut name = ty_name(resolve, false, &ty); - if name.contains(' ') && !name.starts_with('(') && !name.starts_with('[') { - name = format!("({})", name); - } + let name = ty_name(resolve, false, &ty, true); src.push_str(&name); } } @@ -1556,7 +1592,10 @@ fn func_name(func: &Function, ns: Option<&str>) -> String { } } -fn lower_ident(name: &str) -> String { +fn lower_ident(mut name: &str) -> String { + if name.starts_with('[') { + name = &name[name.find(']').unwrap() + 1..]; + } name.to_lower_camel_case() } @@ -1564,7 +1603,7 @@ fn upper_ident(name: &str) -> String { name.to_upper_camel_case() } -fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { +fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type, parens: bool) -> String { match ty { Type::Bool => "Bool".to_owned(), Type::U8 => "Word8".to_owned(), @@ -1604,10 +1643,15 @@ fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { upper_ident(name) } } else { - match &ty.kind { + let name = match &ty.kind { TypeDefKind::Record(_) => todo!(), TypeDefKind::Resource => todo!(), - TypeDefKind::Handle(_) => todo!(), + TypeDefKind::Handle(handle) => match handle { + Handle::Own(id) => upper_ident(&resolve.types[*id].name.clone().unwrap()), + Handle::Borrow(id) => { + upper_ident(&resolve.types[*id].name.clone().unwrap()) + } + }, TypeDefKind::Flags(_) => todo!(), TypeDefKind::Tuple(tuple) => { format!( @@ -1615,7 +1659,7 @@ fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { tuple .types .iter() - .map(|ty| { ty_name(resolve, with_ns, ty) }) + .map(|ty| { ty_name(resolve, with_ns, ty, false) }) .collect::>() .join(", ") ) @@ -1623,28 +1667,33 @@ fn ty_name(resolve: &Resolve, with_ns: bool, ty: &Type) -> String { TypeDefKind::Variant(_) => todo!(), TypeDefKind::Enum(_) => todo!(), TypeDefKind::Option(ty) => { - format!("Maybe {}", ty_name(resolve, with_ns, ty)) + format!("Maybe {}", ty_name(resolve, with_ns, ty, true)) } TypeDefKind::Result(result) => { let ok_ty = if let Some(ty) = result.ok { - ty_name(resolve, with_ns, &ty) + ty_name(resolve, with_ns, &ty, true) } else { "()".to_owned() }; let err_ty = if let Some(ty) = result.err { - ty_name(resolve, with_ns, &ty) + ty_name(resolve, with_ns, &ty, true) } else { "()".to_owned() }; format!("Either {err_ty} {ok_ty}") } TypeDefKind::List(ty) => { - format!("[{}]", ty_name(resolve, with_ns, ty)) + format!("[{}]", ty_name(resolve, with_ns, ty, false)) } TypeDefKind::Future(_) => todo!(), TypeDefKind::Stream(_) => todo!(), - TypeDefKind::Type(ty) => ty_name(resolve, with_ns, ty), + TypeDefKind::Type(ty) => ty_name(resolve, with_ns, ty, parens), TypeDefKind::Unknown => todo!(), + }; + if parens && name.contains(" ") && !name.starts_with(['(', '[']) { + format!("({name})") + } else { + name } } }