From 8645741b0a4ddb66e0f6c518ae3d8d3d7ba493f2 Mon Sep 17 00:00:00 2001 From: Mitchell Vitez Date: Sun, 21 Jun 2026 10:59:48 -0600 Subject: [PATCH] Compile to LLVM IR --- .gitignore | 1 + app/Main.hs | 5 +- doldrums.cabal | 73 +- runtime.rs | 794 ++++++++++++++++ src/Desugar.hs | 13 +- src/FixAst.hs | 37 +- src/Interpret.hs | 147 +-- src/LLVM.hs | 854 ++++++++++++++++-- src/Language.hs | 9 +- src/Lib.hs | 122 ++- src/Prelude.dol | 4 + src/STG.hs | 44 +- src/Typecheck.hs | 17 +- test/Parser.hs | 2 +- test/Spec.hs | 51 +- test/expect/backtick-chained.dol | 2 +- test/expect/backtick-map.dol | 2 +- test/expect/backtick-simple.dol | 2 +- test/expect/big-number.dol | 6 +- test/expect/cycle.dol | 2 +- test/expect/drop-while.dol | 2 +- test/expect/enum_from_to.dol | 2 + test/expect/hello-world.dol | 2 +- test/expect/lines.dol | 2 +- test/expect/list-cons-operator.dol | 2 +- test/expect/list-empty.dol | 2 +- test/expect/list-literal.dol | 2 +- test/expect/list-map.dol | 2 +- test/expect/list-range-step.dol | 2 +- test/expect/list-range.dol | 2 +- test/expect/map-list.dol | 2 +- .../multiple-top-level-pattern-matches.dol | 2 +- test/expect/num-string-print.dol | 5 + test/expect/print_add.dol | 2 + test/expect/range_print.dol | 2 + test/expect/record-multi-accessor.dol | 2 +- test/expect/repeat.dol | 2 +- test/expect/replicate.dol | 2 +- test/expect/section-bound.dol | 2 +- test/expect/section-left-space.dol | 2 +- test/expect/section-left.dol | 2 +- test/expect/section-minus.dol | 2 +- test/expect/section-negation.dol | 2 +- test/expect/section-operator-parens.dol | 2 +- test/expect/section-right-space.dol | 2 +- test/expect/section-right.dol | 2 +- test/expect/show.dol | 2 +- test/expect/show_stg.dol | 2 + test/expect/splitAt_alone.dol | 2 + test/expect/splitAt_range.dol | 3 + test/expect/splitAt_simple.dol | 2 + test/expect/string-escaping.dol | 2 +- test/expect/sub.dol | 2 + test/expect/succ.dol | 2 + test/expect/take-while.dol | 2 +- test/expect/text-concatenation.dol | 2 +- test/expect/tour-checker.dol | 84 ++ test/expect/unlines.dol | 2 +- test/expect/unwords.dol | 2 +- test/expect/words.dol | 2 +- test/expect/zip_len.dol | 2 + tour.dol | 2 +- 62 files changed, 2083 insertions(+), 274 deletions(-) create mode 100644 runtime.rs create mode 100644 test/expect/enum_from_to.dol create mode 100644 test/expect/num-string-print.dol create mode 100644 test/expect/print_add.dol create mode 100644 test/expect/range_print.dol create mode 100644 test/expect/show_stg.dol create mode 100644 test/expect/splitAt_alone.dol create mode 100644 test/expect/splitAt_range.dol create mode 100644 test/expect/splitAt_simple.dol create mode 100644 test/expect/sub.dol create mode 100644 test/expect/succ.dol create mode 100644 test/expect/tour-checker.dol create mode 100644 test/expect/zip_len.dol diff --git a/.gitignore b/.gitignore index 92739b8..54605cd 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ dist-newstyle/ *~ .*.swp todo.md +doldrums-build/ diff --git a/app/Main.hs b/app/Main.hs index 3ec05c8..46358f1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,9 +3,9 @@ module Main where import Lib -import Control.Monad (void) import System.Exit import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Options.Applicative main :: IO () @@ -17,7 +17,8 @@ main = do case inputFilepaths of [file] -> do programText <- T.pack <$> readFile file - void $ execute programText debugFlag compileFlag + result <- execute programText debugFlag compileFlag + TIO.putStrLn result _ -> showHelp exitFailure showHelp :: IO () -> IO () diff --git a/doldrums.cabal b/doldrums.cabal index 79106e7..4a8d5d3 100644 --- a/doldrums.cabal +++ b/doldrums.cabal @@ -17,16 +17,28 @@ source-repository head type: git location: https://github.com/mitchellvitez/doldrums -common warnings +common common ghc-options: -Wall -Wextra -Werror -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wambiguous-fields -Wunused-type-patterns -Wno-unused-do-bind + default-extensions: + OverloadedStrings + LambdaCase + GADTs + TypeOperators + KindSignatures + StandaloneDeriving + BangPatterns + BlockArguments + build-depends: + base >=4.21 && <5 + , text >=1.2 library - import: warnings + import: common exposed-modules: Derive Desugar @@ -43,92 +55,53 @@ library Paths_doldrums hs-source-dirs: src - default-extensions: - OverloadedStrings - LambdaCase - GADTs - TypeOperators - KindSignatures - StandaloneDeriving - BangPatterns build-depends: - base >=4.22 && <5 - , containers >=0.6 + containers >=0.6 , directory >=1.3 , megaparsec >=8.0 , mtl >=2.2 , parser-combinators >=1.2 , process >=1.6 , temporary >=1.3 - , text >=1.2 default-language: GHC2024 executable doldrums - import: warnings + import: common main-is: Main.hs hs-source-dirs: app - default-extensions: - OverloadedStrings - LambdaCase - GADTs - TypeOperators - KindSignatures - StandaloneDeriving - BangPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.22 && <5 - , doldrums - , text >=1.2 + doldrums , optparse-applicative >=0.19 && <1 default-language: GHC2024 test-suite doldrums-test - import: warnings + import: common type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test other-modules: Parser - default-extensions: - OverloadedStrings - LambdaCase - GADTs - TypeOperators - KindSignatures - StandaloneDeriving - BangPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.22 && <5 - , directory >=1.3 + directory >=1.3 , doldrums , filepath >=1.4 - , hspec >=2.7 + , hspec >=2.11 , megaparsec >=8.0 , raw-strings-qq >=1.1 - , text >=1.2 + , process >=1.6 default-language: GHC2024 executable doldrums-repl - import: warnings + import: common main-is: Repl.hs hs-source-dirs: app - default-extensions: - OverloadedStrings - LambdaCase - GADTs - TypeOperators - KindSignatures - StandaloneDeriving - BangPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.22 && <5 - , doldrums - , text >= 1.2 + doldrums , mtl >= 2.2 default-language: GHC2024 diff --git a/runtime.rs b/runtime.rs new file mode 100644 index 0000000..87e0778 --- /dev/null +++ b/runtime.rs @@ -0,0 +1,794 @@ +//! Doldrums runtime. This will be linked into every compiled Doldrums program. + +use std::alloc::{alloc, Layout}; +use std::ffi::CStr; +use std::os::raw::c_char; +use std::ptr; + +//// FunctionPtrs and Values ///// + +/// pointer to a Doldrums function returning a Value +type FunctionPtr = unsafe extern "C" fn(*mut *mut Value) -> *mut Value; + +/// a Value contains a tag (see below) followed by three (optional) u64 fields (a, b, c) +/// this is done to ensure a consistent representation, which simplifies handling +#[repr(C)] +pub struct Value { + tag: u64, + a: u64, + b: u64, + c: u64, +} + +/// below is documented the meaning of each additional Value field + +/// _ _ _ +const TAG_UNIT: u64 = 0; +/// (int value) _ _ +const TAG_INT: u64 = 1; +/// (*const c_char) _ _ +const TAG_STRING: u64 = 2; +/// (constructor tag) (arity) (*const c_char name) +const TAG_CONSTRUCTOR: u64 = 3; +/// (constructor tag) (number of args already applied) (*mut *mut Value array of args) +const TAG_APP_CONSTRUCTOR: u64 = 4; +/// (FunctionPtr) (environment length) (*mut *mut Value array of environment) +const TAG_THUNK: u64 = 5; +/// (FunctionPtr) (arity | environment length [packed]) (*mut *mut Value array of environment|args) +const TAG_FUNCTION: u64 = 6; +const TAG_DOUBLE: u64 = 7; + +///// type tags ///// + +/// type tags (globally unique identifiers for typeclass dispatch) +/// must match the order of data declarations in the prelude: +/// Bool=0, Ordering=1, Maybe=2, List=3, IO=4 +const TYPE_TAG_BOOL: u64 = 100; +const TYPE_TAG_ORDERING: u64 = 101; +const TYPE_TAG_LIST: u64 = 103; +const TYPE_TAG_IO: u64 = 104; + +/// return a unique type ID for a value, used for instance method dispatch. +/// Int = 0, String = 1, Double = 2, Unit = 3, +/// Constructor/AppConstructor = 100 + constructor_tag (globally unique). +#[no_mangle] +pub unsafe extern "C" fn type_id(v: *mut Value) -> *mut Value { + let v = force(v); + let val = &*v; + let id: i64 = match val.tag { + TAG_INT => 0, + TAG_STRING => 1, + TAG_DOUBLE => 2, + TAG_UNIT => 3, + TAG_CONSTRUCTOR => (val.a >> 32) as i64, + TAG_APP_CONSTRUCTOR => (val.a >> 32) as i64, + _ => 9999, + }; + doldrums_int(id) +} + +///// Packing and unpacking arity and env_len ///// + +/// use bottom bits for arity, top bits for env_len +fn pack_arity_env(arity: u64, env_len: u64) -> u64 { + arity | (env_len << 32) +} + +/// grab bottom bits for arity +fn unpack_arity(packed: u64) -> u64 { + packed & 0xFFFFFFFF +} + +/// grab top bits for env_len +fn unpack_env_len(packed: u64) -> u64 { + packed >> 32 +} + +///// Allocating Doldrums values on the heap //// + +/// allocate a new Value on the Doldrums heap +fn alloc_value(tag: u64, a: u64, b: u64, c: u64) -> *mut Value { + unsafe { + let layout = Layout::new::(); + let ptr = alloc(layout) as *mut Value; + if ptr.is_null() { + std::process::abort(); + } + ptr::write(ptr, Value { tag, a, b, c }); + ptr + } +} + +/// create a Doldrums `Int` value from an i64 +/// this is done by allocating a `Value` on the heap +/// each `Value` has a uniform representation +/// for `Int`, that means the `a` field is set to the value of the integer itself +#[no_mangle] +pub unsafe extern "C" fn doldrums_int(x: i64) -> *mut Value { + alloc_value(TAG_INT, x as u64, 0, 0) +} + +/// create a Doldrums `Double` value from an f64 (bits stored in a field) +#[no_mangle] +pub unsafe extern "C" fn doldrums_double(x: i64) -> *mut Value { + alloc_value(TAG_DOUBLE, x as u64, 0, 0) +} + +/// create a Doldrums `String` by copying from a pointer with a length +#[no_mangle] +pub unsafe extern "C" fn doldrums_string(s: *const u8, len: u64) -> *mut Value { + let layout = Layout::array::(len as usize + 1).unwrap(); + let copy = alloc(layout) as *mut u8; + if copy.is_null() { + std::process::abort(); + } + ptr::copy_nonoverlapping(s, copy, len as usize); + *copy.add(len as usize) = 0; + alloc_value(TAG_STRING, copy as u64, 0, 0) +} + +/// create a Doldrums `()` +#[no_mangle] +pub unsafe extern "C" fn doldrums_unit() -> *mut Value { + alloc_value(TAG_UNIT, 0, 0, 0) +} + +/// create a Doldrums constructor (tag, arity, type_tag, name) +/// the type_tag and constructor tag are packed into the `a` field: +/// low 32 bits = constructor tag (per-data-type index) +/// high 32 bits = type tag (globally unique type identifier) +#[no_mangle] +pub unsafe extern "C" fn doldrums_constructor( + tag: u64, + arity: u64, + type_tag: u64, + name: *const c_char, +) -> *mut Value { + let packed_a = (type_tag << 32) | (tag & 0xFFFFFFFF); + alloc_value(TAG_CONSTRUCTOR, packed_a, arity, name as u64) +} + +/// create a Doldrums thunk +/// `fun` is the function to call when the thunk is forced +/// `env_len` is the number of elements in `env` +#[no_mangle] +pub unsafe extern "C" fn doldrums_thunk( + fun: FunctionPtr, + env_len: u64, + env: *mut *mut Value, +) -> *mut Value { + alloc_value(TAG_THUNK, fun as u64, env_len, env as u64) +} + +/// create a Doldrums function +/// `fun` is the function to call when all arguments are applied +/// (i.e. when the function is called with its last argument, arity == 1) +/// `arity` is the total number of arguments to the function +/// `env_len` is the number of elements in `env` +#[no_mangle] +pub unsafe extern "C" fn doldrums_function( + fun: FunctionPtr, + arity: u64, + env_len: u64, + env: *mut *mut Value, +) -> *mut Value { + alloc_value( + TAG_FUNCTION, + fun as u64, + pack_arity_env(arity, env_len), + env as u64, + ) +} + +///// Environment management ///// + +/// allocate a zero-initialized env array of the given size on the heap +/// the caller must ensure the allocated memory is not freed while any thunk references it +#[no_mangle] +pub unsafe extern "C" fn allocate_environment(n: u64) -> *mut *mut Value { + let layout = Layout::array::<*mut Value>(n as usize).unwrap(); + let env = alloc(layout) as *mut *mut Value; + if env.is_null() { + std::process::abort(); + } + for i in 0..n as usize { + ptr::write(env.add(i), std::ptr::null_mut()); + } + env +} + +/// add a new pointer to Value to the env array +#[no_mangle] +pub unsafe extern "C" fn extend_environment( + env: *mut *mut Value, + env_len: u64, + val: *mut Value, +) -> *mut *mut Value { + let new_len = env_len + 1; + let layout = Layout::array::<*mut Value>(new_len as usize).unwrap(); + let new_env = alloc(layout) as *mut *mut Value; + if new_env.is_null() { + std::process::abort(); + } + if !env.is_null() { + ptr::copy_nonoverlapping(env, new_env, env_len as usize); + } + *new_env.add(env_len as usize) = val; + new_env +} + +///// evaluation ///// + +/// force a value to WHNF +/// if the value is a thunk, evaluate it +/// return a pointer to the evaluated value +#[no_mangle] +#[inline(never)] +pub unsafe extern "C" fn force(mut v: *mut Value) -> *mut Value { + loop { + let val = &*v; + if val.tag != TAG_THUNK { + return v; + } + let fun: FunctionPtr = std::mem::transmute(val.a); + let env_len = val.b; + let env = if env_len == 0 { + std::ptr::null_mut() + } else { + val.c as *mut *mut Value + }; + let result = fun(env); + if result != v { + v = result; + } else { + return v; + } + } +} + +/// apply a function to an argument +/// +/// TAG_FUNCTION: partially apply if arity > 1, fully apply (call fn) if arity == 1 +/// TAG_CONSTRUCTOR: accumulate arguments in APP_CONSTRUCTOR +/// TAG_APP_CONSTRUCTOR: extend the args array +#[no_mangle] +pub unsafe extern "C" fn apply(f: *mut Value, arg: *mut Value) -> *mut Value { + let f = force(f); + let val = &*f; + match val.tag { + TAG_FUNCTION => { + let fun: FunctionPtr = std::mem::transmute(val.a); + let packed = val.b; + let arity = unpack_arity(packed); + let env_len = unpack_env_len(packed); + let env = val.c as *mut *mut Value; + + let res = if arity == 1 { + let new_env = extend_environment(env, env_len, arg); + fun(new_env) + } else { + let new_env = extend_environment(env, env_len, arg); + alloc_value( + TAG_FUNCTION, + val.a, + pack_arity_env(arity - 1, env_len + 1), + new_env as u64, + ) + }; + res + } + TAG_CONSTRUCTOR => { + let name_ptr = val.c as *const c_char; + let args_layout = Layout::array::<*mut Value>(2).unwrap(); + let args = alloc(args_layout) as *mut *mut Value; + if args.is_null() { + std::process::abort(); + } + *args = name_ptr as *mut Value; + *args.add(1) = arg; + alloc_value(TAG_APP_CONSTRUCTOR, val.a, 1, args as u64) + } + TAG_APP_CONSTRUCTOR => { + let num_args = val.b; + let old_args = val.c as *mut *mut Value; + let new_num = num_args + 1; + let layout = Layout::array::<*mut Value>(new_num as usize + 1).unwrap(); + let new_args = alloc(layout) as *mut *mut Value; + if new_args.is_null() { + std::process::abort(); + } + ptr::copy_nonoverlapping(old_args, new_args, (num_args as usize) + 1); + *new_args.add((num_args as usize) + 1) = arg; + alloc_value(TAG_APP_CONSTRUCTOR, val.a, new_num, new_args as u64) + } + _ => { + std::process::abort(); + } + } +} + +///// primitive functions (to end of file) ///// + +/// + +#[no_mangle] +pub unsafe extern "C" fn primitive_add_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(add_num_continuation as FunctionPtr, 1, 1, env) +} + +/// each primitive function is supported by a continuation function pointer +/// for doldrums_function to use +unsafe extern "C" fn add_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + doldrums_double(f64::to_bits(to_f64(a) + to_f64(b)) as i64) + } else { + doldrums_int(to_i64(a).wrapping_add(to_i64(b))) + } +} + +/// - +#[no_mangle] +pub unsafe extern "C" fn primitive_subtract_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(subtract_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn subtract_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + doldrums_double(f64::to_bits(to_f64(a) - to_f64(b)) as i64) + } else { + doldrums_int(to_i64(a).wrapping_sub(to_i64(b))) + } +} + +/// * +#[no_mangle] +pub unsafe extern "C" fn primitive_multiply_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(multiply_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn multiply_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + doldrums_double(f64::to_bits(to_f64(a) * to_f64(b)) as i64) + } else { + doldrums_int(to_i64(a).wrapping_mul(to_i64(b))) + } +} + +/// / +#[no_mangle] +pub unsafe extern "C" fn primitive_divide_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(divide_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn divide_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + doldrums_double(f64::to_bits(to_f64(a) / to_f64(b)) as i64) + } else { + doldrums_int(to_i64(a).wrapping_div(to_i64(b))) + } +} + +/// == +#[no_mangle] +pub unsafe extern "C" fn primitive_eq_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(eq_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn eq_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + let eq = if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + to_f64(a) == to_f64(b) + } else { + to_i64(a) == to_i64(b) + }; + let true_name = CStr::from_bytes_with_nul_unchecked(b"True\0"); + let false_name = CStr::from_bytes_with_nul_unchecked(b"False\0"); + if eq { + doldrums_constructor(0, 0, TYPE_TAG_BOOL, true_name.as_ptr()) + } else { + doldrums_constructor(1, 0, TYPE_TAG_BOOL, false_name.as_ptr()) + } +} + +/// /= +#[no_mangle] +pub unsafe extern "C" fn primitive_neq_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(neq_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn neq_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + let neq = if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + to_f64(a) != to_f64(b) + } else { + to_i64(a) != to_i64(b) + }; + let true_name = CStr::from_bytes_with_nul_unchecked(b"True\0"); + let false_name = CStr::from_bytes_with_nul_unchecked(b"False\0"); + if neq { + doldrums_constructor(0, 0, TYPE_TAG_BOOL, true_name.as_ptr()) + } else { + doldrums_constructor(1, 0, TYPE_TAG_BOOL, false_name.as_ptr()) + } +} + +/// compare +#[no_mangle] +pub unsafe extern "C" fn primitive_compare_num(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(compare_num_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn compare_num_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + let lt_name = CStr::from_bytes_with_nul_unchecked(b"LT\0"); + let eq_name = CStr::from_bytes_with_nul_unchecked(b"EQ\0"); + let gt_name = CStr::from_bytes_with_nul_unchecked(b"GT\0"); + let ord = if (*a).tag == TAG_DOUBLE || (*b).tag == TAG_DOUBLE { + to_f64(a).partial_cmp(&to_f64(b)) + } else { + Some(to_i64(a).cmp(&to_i64(b))) + }; + match ord { + Some(std::cmp::Ordering::Less) => { + doldrums_constructor(0, 0, TYPE_TAG_ORDERING, lt_name.as_ptr()) + } + Some(std::cmp::Ordering::Equal) => { + doldrums_constructor(1, 0, TYPE_TAG_ORDERING, eq_name.as_ptr()) + } + Some(std::cmp::Ordering::Greater) => { + doldrums_constructor(2, 0, TYPE_TAG_ORDERING, gt_name.as_ptr()) + } + None => doldrums_constructor(1, 0, TYPE_TAG_ORDERING, eq_name.as_ptr()), + } +} + +/// putStrLn +#[no_mangle] +pub unsafe extern "C" fn primitive_putStrLn(s: *mut Value) -> *mut Value { + let v = force(s); + let val = &*v; + if val.tag != TAG_STRING { + std::process::abort(); + } + let c_str = val.a as *const c_char; + let rust_str = CStr::from_ptr(c_str).to_str().unwrap(); + println!("{}", rust_str); + return_io_unit() +} + +/// print +#[no_mangle] +pub unsafe extern "C" fn primitive_print(v: *mut Value) -> *mut Value { + let v = force(v); + let s = value_to_string(v); + println!("{}", s); + return_io_unit() +} + +/// show +#[no_mangle] +pub unsafe extern "C" fn primitive_show(v: *mut Value) -> *mut Value { + let v = force(v); + let s = value_to_string(v); + doldrums_string(s.as_ptr(), s.len() as u64) +} + +/// <> +#[no_mangle] +pub unsafe extern "C" fn primitive_append_string(x: *mut Value) -> *mut Value { + let env = extend_environment(std::ptr::null_mut(), 0, x); + doldrums_function(append_string_continuation as FunctionPtr, 1, 1, env) +} + +unsafe extern "C" fn append_string_continuation(env: *mut *mut Value) -> *mut Value { + let a = force(*env); + let b = force(*env.add(1)); + if (*a).tag != TAG_STRING || (*b).tag != TAG_STRING { + std::process::abort(); + } + let a_str = CStr::from_ptr((*a).a as *const c_char).to_str().unwrap(); + let b_str = CStr::from_ptr((*b).a as *const c_char).to_str().unwrap(); + let result = format!("{}{}", a_str, b_str); + doldrums_string(result.as_ptr(), result.len() as u64) +} + +/// lines +#[no_mangle] +pub unsafe extern "C" fn primitive_lines(x: *mut Value) -> *mut Value { + string_to_list(x, |s| s.lines().collect()) +} + +/// words +#[no_mangle] +pub unsafe extern "C" fn primitive_words(x: *mut Value) -> *mut Value { + string_to_list(x, |s| s.split_whitespace().collect()) +} + +/// floor +#[no_mangle] +pub unsafe extern "C" fn primitive_floor(x: *mut Value) -> *mut Value { + let v = force(x); + if (*v).tag != TAG_DOUBLE { + std::process::abort(); + } + let d = f64::from_bits((*v).a); + doldrums_int(d.floor() as i64) +} + +/// ceiling +#[no_mangle] +pub unsafe extern "C" fn primitive_ceiling(x: *mut Value) -> *mut Value { + let v = force(x); + if (*v).tag != TAG_DOUBLE { + std::process::abort(); + } + let d = f64::from_bits((*v).a); + doldrums_int(d.ceil() as i64) +} + +/// round +#[no_mangle] +pub unsafe extern "C" fn primitive_round(x: *mut Value) -> *mut Value { + let v = force(x); + if (*v).tag != TAG_DOUBLE { + std::process::abort(); + } + let d = f64::from_bits((*v).a); + doldrums_int(d.round() as i64) +} + +/// pure :: a -> IO a +#[no_mangle] +pub unsafe extern "C" fn primitive_pure_io(x: *mut Value) -> *mut Value { + let io_name = CStr::from_bytes_with_nul_unchecked(b"IO\0"); + let io_cons = doldrums_constructor(1, 1, TYPE_TAG_IO, io_name.as_ptr()); + apply(io_cons, x) +} + +#[no_mangle] +pub unsafe extern "C" fn primitive_unlines(x: *mut Value) -> *mut Value { + list_to_string(x, |strings| strings.join("\n") + "\n") +} + +#[no_mangle] +pub unsafe extern "C" fn primitive_unwords(x: *mut Value) -> *mut Value { + list_to_string(x, |strings| strings.join(" ")) +} + +///// helpers for primitives ///// + +#[inline] +unsafe fn to_f64(v: *mut Value) -> f64 { + match (*v).tag { + TAG_DOUBLE => f64::from_bits((*v).a), + TAG_INT => (*v).a as i64 as f64, + _ => 0.0, + } +} + +#[inline] +unsafe fn to_i64(v: *mut Value) -> i64 { + (*v).a as i64 +} + +/// return a doldrums `IO ()` Value +unsafe fn return_io_unit() -> *mut Value { + let unit = doldrums_unit(); + let io_name = CStr::from_bytes_with_nul_unchecked(b"IO\0"); + let io_cons = doldrums_constructor(1, 1, TYPE_TAG_IO, io_name.as_ptr()); + apply(io_cons, unit) +} + +/// find constructor names for applied or unapplied constructors +fn get_cons_name(v: *mut Value) -> Option { + unsafe { + let val = &*v; + match val.tag { + TAG_CONSTRUCTOR => { + let name_ptr = val.c as *const c_char; + if name_ptr.is_null() { + None + } else { + Some(CStr::from_ptr(name_ptr).to_str().unwrap().to_string()) + } + } + TAG_APP_CONSTRUCTOR => { + let args = val.c as *mut *mut Value; + let name_ptr = *args as *const c_char; + if name_ptr.is_null() { + None + } else { + Some(CStr::from_ptr(name_ptr).to_str().unwrap().to_string()) + } + } + _ => None, + } + } +} + +/// detect whether a `show` on a Doldrums value needs parentheses +fn needs_parens(v: *mut Value) -> bool { + unsafe { + let val = &*v; + if val.tag == TAG_APP_CONSTRUCTOR { + if let Some(name) = get_cons_name(v) { + if name == "Cons" { + return false; + } + } + return true; + } + false + } +} + +/// `show` with [1,2,3] list syntax supported +fn show_list(v: *mut Value) -> Option { + unsafe { + let name = get_cons_name(v)?; + if name != "Cons" { + return None; + } + let mut elements: Vec = Vec::new(); + let mut current = v; + loop { + let cur_val = &*current; + match cur_val.tag { + TAG_APP_CONSTRUCTOR => { + let cur_args = cur_val.c as *mut *mut Value; + let cur_name_ptr = *cur_args as *const c_char; + let cur_name = CStr::from_ptr(cur_name_ptr).to_str().unwrap(); + if cur_name != "Cons" { + return None; + } + let head = force(*cur_args.add(1)); + elements.push(value_to_string(head)); + current = force(*cur_args.add(2)); + } + TAG_CONSTRUCTOR => { + let cur_name_ptr = cur_val.c as *const c_char; + let cur_name = CStr::from_ptr(cur_name_ptr).to_str().unwrap(); + if cur_name == "Nil" { + return Some(format!("[{}]", elements.join(","))); + } + return None; + } + _ => return None, + } + } + } +} + +fn value_to_string(v: *mut Value) -> String { + unsafe { + let val = &*v; + match val.tag { + TAG_INT => format!("{}", val.a as i64), + TAG_DOUBLE => { + let d = f64::from_bits(val.a); + let s = format!("{}", d); + if s.contains('.') { + s + } else { + format!("{}.0", d as i64) + } + } + TAG_STRING => { + let c_str = val.a as *const c_char; + let s = CStr::from_ptr(c_str).to_str().unwrap(); + format!("\"{}\"", s.escape_default()) + } + TAG_CONSTRUCTOR => { + let name_ptr = val.c as *const c_char; + if name_ptr.is_null() { + format!("", val.a) + } else { + let name = CStr::from_ptr(name_ptr).to_str().unwrap().to_string(); + if name == "Nil" { + "[]".to_string() + } else { + name + } + } + } + TAG_APP_CONSTRUCTOR => { + if let Some(s) = show_list(v) { + return s; + } + let num_args = val.b; + let args = val.c as *mut *mut Value; + let name_ptr = *args as *const c_char; + let mut result = if name_ptr.is_null() { + format!("", val.a) + } else { + CStr::from_ptr(name_ptr).to_str().unwrap().to_string() + }; + for i in 0..num_args as usize { + result.push(' '); + let arg_val = force(*args.add(i + 1)); + let arg_str = value_to_string(arg_val); + if needs_parens(arg_val) { + result.push('('); + result.push_str(&arg_str); + result.push(')'); + } else { + result.push_str(&arg_str); + } + } + result + } + TAG_UNIT => "()".to_string(), + TAG_FUNCTION => "".to_string(), + TAG_THUNK => "".to_string(), + _ => format!("", val.tag), + } + } +} + +unsafe fn string_to_list(s_ptr: *mut Value, split_fn: impl Fn(&str) -> Vec<&str>) -> *mut Value { + let s = force(s_ptr); + if (*s).tag != TAG_STRING { + std::process::abort(); + } + let s_str = CStr::from_ptr((*s).a as *const c_char).to_str().unwrap(); + let items = split_fn(s_str); + let nil_name = CStr::from_bytes_with_nul_unchecked(b"Nil\0"); + let cons_name = CStr::from_bytes_with_nul_unchecked(b"Cons\0"); + let mut result = std::ptr::null_mut::(); + for item in items.into_iter().rev() { + let item_val = doldrums_string(item.as_ptr(), item.len() as u64); + let cons = doldrums_constructor(1, 2, TYPE_TAG_LIST, cons_name.as_ptr()); + let applied = apply(cons, item_val); + if result.is_null() { + result = doldrums_constructor(0, 0, TYPE_TAG_LIST, nil_name.as_ptr()); + } + result = apply(applied, result); + } + if result.is_null() { + doldrums_constructor(0, 0, TYPE_TAG_LIST, nil_name.as_ptr()) + } else { + result + } +} + +unsafe fn list_to_string(x: *mut Value, join_fn: impl Fn(Vec) -> String) -> *mut Value { + let list = force(x); + let mut strings: Vec = Vec::new(); + let mut current = list; + loop { + let val = &*current; + if val.tag == TAG_CONSTRUCTOR && (val.a & 0xFFFFFFFF) == 0 { + break; + } else if val.tag == TAG_APP_CONSTRUCTOR && (val.a & 0xFFFFFFFF) == 1 { + let args = val.c as *mut *mut Value; + let head = force(*args.add(1)); + if (*head).tag != TAG_STRING { + std::process::abort(); + } + let s = CStr::from_ptr((*head).a as *const c_char).to_str().unwrap(); + strings.push(s.to_string()); + current = force(*args.add(2)); + } else { + std::process::abort(); + } + } + let result = join_fn(strings); + doldrums_string(result.as_ptr(), result.len() as u64) +} diff --git a/src/Desugar.hs b/src/Desugar.hs index e254f65..81122f2 100644 --- a/src/Desugar.hs +++ b/src/Desugar.hs @@ -236,13 +236,12 @@ desugarExpr dds expr = Nothing -> mappedExpr mapExpr :: [DataDeclaration] -> (AnnotatedExpr a -> AnnotatedExpr a) -> AnnotatedExpr a -> AnnotatedExpr a -mapExpr _ _ (AnnExprVariable a n) = AnnExprVariable a n -mapExpr _ _ (AnnExprLiteral a l) = AnnExprLiteral a l -mapExpr _ _ (AnnExprConstructor a tag arity) = AnnExprConstructor a tag arity -mapExpr _ f (AnnExprApplication a e1 e2) = AnnExprApplication a (f e1) (f e2) -mapExpr _ f (AnnExprLet a bindings body) = AnnExprLet a [(name, f binding) | (name, binding) <- bindings] (f body) -mapExpr _ f (AnnExprLambda a n e) = AnnExprLambda a n (f e) -mapExpr d f (AnnExprCase a e alts) = AnnExprCase a (f e) (map (\(Alternative pat body) -> Alternative (desugarPattern d pat) (f body)) alts) +mapExpr d f = \case + AnnExprApplication a e1 e2 -> AnnExprApplication a (f e1) (f e2) + AnnExprLet a bindings body -> AnnExprLet a [(n, f b) | (n, b) <- bindings] (f body) + AnnExprLambda a n e -> AnnExprLambda a n (f e) + AnnExprCase a e alts -> AnnExprCase a (f e) [Alternative (desugarPattern d p) (f b) | Alternative p b <- alts] + e -> e -- | Desugar record patterns to constructor patterns diff --git a/src/FixAst.hs b/src/FixAst.hs index 88f7c8a..339ad4d 100644 --- a/src/FixAst.hs +++ b/src/FixAst.hs @@ -51,9 +51,8 @@ genAccessorsForDataDecl :: DataDeclaration -> [Function ()] genAccessorsForDataDecl dd = [ let body = AnnExprVariable () (xArg tag fieldIdx) numArgs = length $ constructorArgTypes args - patArgs = replicate numArgs PatternWildcard - patArgsWithField = replaceNth fieldIdx (PatternVar (xArg tag fieldIdx)) patArgs - patternArg = PatternConstructor tag patArgsWithField + patArgs = [PatternVar (xArg tag i) | i <- [0..numArgs-1]] + patternArg = PatternConstructor tag patArgs in Function () fieldName [patternArg] body | (tag, args) <- declarations dd , isRecordConstructor args @@ -63,11 +62,6 @@ genAccessorsForDataDecl dd = xArg :: Tag -> Int -> Name xArg (Tag t) i = Name $ "x_" <> t <> "_" <> T.pack (show i) -replaceNth :: Int -> a -> [a] -> [a] -replaceNth _ _ [] = [] -replaceNth 0 y (_:xs) = y : xs -replaceNth n y (x:xs) = x : replaceNth (n-1) y xs - -- generate instance declaration code from `deriving` clauses deriveProgram :: Program a -> Program a deriveProgram program@Program{..} = @@ -219,17 +213,20 @@ filterReachable program@Program{..} } where functionNames = Set.fromList $ map name functions - live = until (\s -> step s == s) step $ - Set.singleton (Name "main") `Set.union` - Set.unions (concatMap (map (refs . snd) . instanceMethods) instanceDeclarations) - step s = s `Set.union` Set.unions (map (refs . body) $ filter ((`Set.member` s) . name) functions) - refs (AnnExprVariable _ name) - | name `Set.member` functionNames = Set.singleton name + live = until (\s -> step s == s) step $ Set.singleton (Name "main") + step s = s `Set.union` Set.unions (map (refs Set.empty . body) $ filter ((`Set.member` s) . name) functions) + refs :: Set Name -> AnnotatedExpr a -> Set Name + refs bound (AnnExprVariable _ name) + | name `Set.member` functionNames && name `Set.notMember` bound = Set.singleton name | otherwise = Set.empty - refs (AnnExprApplication _ f x) = refs f `Set.union` refs x - refs (AnnExprLet _ bindings body) = Set.unions (map (refs . snd) bindings) `Set.union` refs body - refs (AnnExprLambda _ _ expr) = refs expr - refs (AnnExprCase _ scrutinee alts) = refs scrutinee `Set.union` Set.unions [refs body | Alternative _ body <- alts] - - refs _ = Set.empty + refs bound (AnnExprApplication _ f x) = refs bound f `Set.union` refs bound x + refs bound (AnnExprLet _ bindings body) = + let bnd = Set.union bound (Set.fromList (map fst bindings)) + in Set.unions (map (refs bnd . snd) bindings) `Set.union` refs bnd body + refs bound (AnnExprLambda _ n expr) = refs (Set.insert n bound) expr + refs bound (AnnExprCase _ scrutinee alts) = + refs bound scrutinee `Set.union` + Set.unions [refs (Set.union bound (Set.fromList (patternNames pat))) body + | Alternative pat body <- alts] + refs _ _ = Set.empty diff --git a/src/Interpret.hs b/src/Interpret.hs index a392c3d..c5f5978 100644 --- a/src/Interpret.hs +++ b/src/Interpret.hs @@ -204,12 +204,39 @@ withEnv newEnv action = do modify $ \s -> s { env = oldEnv } pure result --- | evaluate an Expr to weak head normal form. this is as far as `force` goes +binaryOps :: Map Text (Expr -> Expr -> Eval Value) +binaryOps = Map.fromList + [ ("<>", strBinOp) + , ("+", numBinOp (+) (+)) + , ("-", numBinOp (-) (-)) + , ("*", numBinOp (*) (*)) + , ("/", numBinOp (div) (/)) + , ("==", eqNeqFallback "==") + , ("/=", eqNeqFallback "/=") + , ("compare", compareFallback) + , ("writeFile", writeFileOp) + ] + +unaryOps :: Map Text (Expr -> Eval Value) +unaryOps = Map.fromList + [ ("words", wordsPrim) + , ("lines", linesPrim) + , ("unwords", unwordsPrim) + , ("unlines", unlinesPrim) + , ("floor", floorPrim) + , ("ceiling", ceilingPrim) + , ("round", roundPrim) + , ("print", printOp) + , ("putStrLn", putStrLnOp) + , ("readFile", readFileOp) + , ("pure", pureOp) + ] + +-- | Evaluate an Expr to weak head normal form. this is as far as `force` goes whnf :: Expr -> Eval Value whnf (ExprLiteral l) = pure $ ValLiteral l whnf (ExprConstructor tag arity) = pure $ ValConstructor tag arity whnf (ExprLambda name body) = do - -- capture the current env in the closure currentEnv <- gets env pure $ ValClosure name body currentEnv whnf (ExprVariable name) @@ -217,10 +244,9 @@ whnf (ExprVariable name) s <- liftIO getLine return $ ValLiteral (LiteralString (pack s)) | otherwise = do - -- check if this is a typeclass method name first mMethod <- gets (Map.lookup name . methodEnv) case mMethod of - Just dispatchTable -> do + Just dispatchTable -> pure $ ValMethodDispatch name dispatchTable Nothing -> do currentEnv <- gets env @@ -229,66 +255,45 @@ whnf (ExprVariable name) Nothing -> throw $ RuntimeException $ "Unbound variable: " <> tshow name whnf (ExprLet bindings body) = do s <- get - let - -- to allow mutual recursion, write out all bindings as thunks - names = map fst bindings - exprs = map snd bindings - baseTid = unThunkId $ nextId s - tids = map ThunkId [baseTid .. baseTid + length bindings - 1] - recEnv = foldr (\(n, tid) e -> Map.insert n tid e) (env s) $ zip names tids - newHeap = foldr - (\(tid, expr) h -> IntMap.insert (unThunkId tid) (Thunk recEnv expr) h) - (heap s) - (zip tids exprs) + let names = map fst bindings + exprs = map snd bindings + baseTid = unThunkId $ nextId s + tids = map ThunkId [baseTid .. baseTid + length bindings - 1] + recEnv = foldr (\(n, tid) e -> Map.insert n tid e) (env s) $ zip names tids + newHeap = foldr + (\(tid, expr) h -> IntMap.insert (unThunkId tid) (Thunk recEnv expr) h) + (heap s) + (zip tids exprs) put s { heap = newHeap , nextId = ThunkId $ baseTid + length bindings , env = recEnv } whnf body + -- binary operations whnf (ExprApplication (ExprApplication (ExprVariable (Name op)) a) b) = - case op of - -- primitive ops (typeclass-aware dispatch) - "<>" -> strBinOp a b - "+" -> numBinOp (+) (+) a b - "-" -> numBinOp (-) (-) a b - "*" -> numBinOp (*) (*) a b - "/" -> numBinOp (div) (/) a b - -- equality dispatches through method system; primitives handled directly - "==" -> eqNeqFallback "==" a b - "/=" -> eqNeqFallback "/=" a b - -- compare: try primitive first, then method dispatch - "compare" -> compareFallback a b - "writeFile" -> writeFileOp a b - _ -> doMethodBinaryOp op a b + case Map.lookup op binaryOps of + Just prim -> prim a b + Nothing -> doMethodBinaryOp op a b -- unary operations whnf (ExprApplication (ExprVariable (Name op)) arg) | op == "show" = methodUnaryOp "show" arg showPrim - | op == "words" = wordsPrim arg - | op == "lines" = linesPrim arg - | op == "unwords" = unwordsPrim arg - | op == "unlines" = unlinesPrim arg - | op == "floor" = floorPrim arg - | op == "ceiling" = ceilingPrim arg - | op == "round" = roundPrim arg - | op == "print" = printOp arg - | op == "putStrLn" = putStrLnOp arg - | op == "readFile" = readFileOp arg - | op == "pure" = pureOp arg - | otherwise = do - mMethod <- gets (Map.lookup (Name op) . methodEnv) - case mMethod of - Just dispatchTable -> - applyValue (ValMethodDispatch (Name op) dispatchTable) arg - Nothing -> do - currentEnv <- gets env - case Map.lookup (Name op) currentEnv of - Just tid -> do - funcVal <- force tid - applyValue funcVal arg - Nothing -> throw $ RuntimeException $ "Unbound variable: " <> op + | otherwise = case Map.lookup op unaryOps of + Just prim -> prim arg + Nothing -> do + mMethod <- gets $ Map.lookup (Name op) . methodEnv + case mMethod of + Just dispatchTable -> + applyValue (ValMethodDispatch (Name op) dispatchTable) arg + Nothing -> do + currentEnv <- gets env + case Map.lookup (Name op) currentEnv of + Just tid -> do + funcVal <- force tid + applyValue funcVal arg + Nothing -> throw $ RuntimeException $ "Unbound variable: " <> op -- function applications whnf (ExprApplication func arg) = do @@ -574,7 +579,6 @@ printOp arg = do val <- whnf arg str <- unpackValue val modify $ \s -> s { outputLines = str : outputLines s } - liftIO $ putStrLn (unpack str) wrapInIO $ ValConstructor (Tag "Unit") (Arity 0) putStrLnOp :: Expr -> Eval Value @@ -583,7 +587,6 @@ putStrLnOp arg = do case val of ValLiteral (LiteralString str) -> do modify $ \st -> st { outputLines = str : outputLines st } - liftIO $ putStrLn (unpack str) wrapInIO $ ValConstructor (Tag "Unit") (Arity 0) _ -> throw $ RuntimeException "putStrLn requires a String" @@ -601,18 +604,38 @@ pureOp arg = do val <- whnf arg wrapInIO val +collectListElements :: Value -> Eval [Text] +collectListElements v = case unApply v [] of + Right (tag, _, args) + | unTag tag == "Nil" -> pure [] + | unTag tag == "Cons", [h, t] <- args -> do + hVal <- force h + hText <- unpackValue hVal + tVal <- force t + tTexts <- collectListElements tVal + pure (hText : tTexts) + | otherwise -> throw $ RuntimeException "Not a list" + Left _ -> throw $ RuntimeException "Not a list" + unpackValue :: Value -> Eval Text unpackValue (ValLiteral (LiteralInt n)) = pure $ tshow n -unpackValue (ValLiteral (LiteralString s)) = pure s +unpackValue (ValLiteral (LiteralString s)) = pure $ tshow s unpackValue (ValLiteral (LiteralDouble f)) = pure $ tshow f -unpackValue (ValConstructor tag (Arity 0)) = pure $ unTag tag +unpackValue (ValConstructor tag (Arity 0)) + | unTag tag == "Nil" = pure "[]" + | otherwise = pure $ unTag tag unpackValue (ValConstructor tag _) = pure $ " unTag tag <> ">" unpackValue (ValClosure _ _ _) = pure "" unpackValue v = case unApply v [] of - Right (tag, _, args) -> do - argsText <- forM args $ \tid -> do - val <- force tid - innerText <- unpackValue val - pure $ if T.any (== ' ') innerText then "(" <> innerText <> ")" else innerText - pure $ T.unwords (unTag tag : argsText) + Right (tag, _, args) + | unTag tag == "Cons" -> do + elements <- collectListElements v + pure $ "[" <> T.intercalate "," elements <> "]" + | unTag tag == "Nil" -> pure "[]" + | otherwise -> do + argsText <- forM args $ \tid -> do + val <- force tid + innerText <- unpackValue val + pure $ if T.any (== ' ') innerText then "(" <> innerText <> ")" else innerText + pure $ T.unwords (unTag tag : argsText) Left _ -> pure $ "Incomplete evaluation: " <> tshow v diff --git a/src/LLVM.hs b/src/LLVM.hs index f33b4d9..4abd5d1 100644 --- a/src/LLVM.hs +++ b/src/LLVM.hs @@ -1,70 +1,812 @@ +{-# LANGUAGE MultilineStrings #-} + module LLVM - ( compileAndRun - ) where + ( runLLVM + , compileLLVM + ) +where import STG +import Language +import Control.Monad (when) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import System.IO.Temp (withSystemTempDirectory) -import System.Process (readProcessWithExitCode) +import Data.Text qualified as T +import Data.Text.IO qualified as TIO +import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime) import System.Exit (ExitCode(..)) -import Control.Monad (when) +import System.IO.Temp (createTempDirectory) +import System.Process (readProcessWithExitCode) + +-- | take LLVM IR, assemble, link against the Rust runtime, +-- run the binary, and return the program's output +runLLVM :: Text -> IO Text +runLLVM llvmModuleText = do + let topLevelBuildDir = "doldrums-build" + createDirectoryIfMissing True topLevelBuildDir + buildDir <- createTempDirectory topLevelBuildDir "build" + let llPath = buildDir <> "/program.ll" + objPath = buildDir <> "/program.o" + binPath = buildDir <> "/program" + rtObj = topLevelBuildDir <> "/libruntime.a" + + TIO.writeFile llPath llvmModuleText + + (exitCode1, output1, error1) <- readProcessWithExitCode "clang" + ["-c", llPath, "-o", objPath, "-Wno-override-module"] "" + when (exitCode1 /= ExitSuccess) $ + error $ "LLVM assembly failed:\n" <> error1 <> "\n" <> output1 + + runtimeObjStale <- shouldRebuild "runtime.rs" rtObj + when runtimeObjStale $ do + (exitCode2, _, error2) <- readProcessWithExitCode "rustc" + ["runtime.rs", "--crate-type", "staticlib", "-o", rtObj, "-O"] "" + when (exitCode2 /= ExitSuccess) $ + error $ "Runtime compilation failed: " <> error2 + + (exitCode3, _, error3) <- readProcessWithExitCode "clang" + [objPath, rtObj, "-o", binPath] "" + when (exitCode3 /= ExitSuccess) $ + error $ "Linking failed:\n" <> error3 + + (exitCode4, output, error4) <- readProcessWithExitCode binPath [] "" + when (exitCode4 /= ExitSuccess) $ + error $ "Runtime error:\n" <> error4 <> "\n\noutput was:\n" + + pure $ T.pack output + +shouldRebuild :: FilePath -> FilePath -> IO Bool +shouldRebuild src dst = do + srcExists <- doesFileExist src + dstExists <- doesFileExist dst + if not srcExists then pure False + else if not dstExists then pure True + else do + srcTime <- getModificationTime src + dstTime <- getModificationTime dst + pure (srcTime > dstTime) + +-- | compile STG to LLVM IR, as plain Text +compileLLVM :: StgExpr -> [DataDeclaration] -> Text +compileLLVM stg dataDecls = + let + consMap = buildConstructorMap dataDecls + strings = collectStrings stg <> collectConstructorNames consMap + strTable = buildStringTable strings + allBnds = collectAllBindings stg + extraNames = collectExtraNames stg + noThunkNames = extraNames + bodyExpr = stripLets stg + bnds = dedupByName $ filterReachable bodyExpr allBnds + nameMap = buildNameMap bnds extraNames + bindingArities = Map.fromList + [ (stgName b, length (stgArgs b)) + | b <- bnds + , not (null (stgArgs b)) + ] + thunkBodyMap = Map.fromList + [ (stgName b, stgBody b) + | b <- bnds + , null (stgArgs b) + ] + in T.unlines $ concat + [ [header] + , [externDecls] + , map (genStrConst strTable) $ Set.toList strings + , [""] + , map (\b -> compileBinding b strTable nameMap consMap extraNames thunkBodyMap) bnds + , [compileBodyFunc bodyExpr strTable nameMap consMap thunkBodyMap bnds] + , [entryPoint nameMap bindingArities noThunkNames bnds] + , [mainFunc] + ] + +type StringTable = Map Text Text + +type NameMap = Map Text Text + +type ConstructorMap = Map Text (Int, Arity, Int) + +collectConstructorNames :: ConstructorMap -> Set Text +collectConstructorNames = Map.keysSet + +dedupByName :: [StgBinding] -> [StgBinding] +dedupByName = Map.elems . Map.fromList . map (\b -> (stgName b, b)) . reverse + +filterReachable :: StgExpr -> [StgBinding] -> [StgBinding] +filterReachable body allBnds = + filter (\b -> stgName b `Set.member` live) allBnds + where + names = Set.fromList (map stgName allBnds) + start = usedNames names body + step s = s `Set.union` Set.unions + [ usedNames names (stgBody b) + | b <- allBnds + , stgName b `Set.member` s + ] + live = until (\s -> step s == s) step start + + usedNames ns = \case + StgAtom a -> usedNamesAtom ns a + StgApp n as -> Set.insert n $ foldMap (usedNamesAtom ns) as + StgLet bs b' -> foldMap (usedNames ns . stgBody) bs <> usedNames ns b' + StgCase a alts -> usedNamesAtom ns a <> foldMap f alts + where + f (StgAlt _ bs b') = foldMap (usedNames ns . stgBody) bs <> usedNames ns b' + usedNamesAtom ns = \case + StgAtomVar n -> if n `Set.member` ns then Set.singleton n else Set.empty + _ -> Set.empty + +header :: Text +header = T.pack """ +; ModuleID = 'doldrums' +target triple = "arm64-apple-macosx15.0.0" +%Value = type { i64, i64, i64, i64 } +""" + +externDecls :: Text +externDecls = T.pack """ +; construct Doldrums `Value`s on the heap +declare %Value* @doldrums_int(i64) +declare %Value* @doldrums_double(i64) +declare %Value* @doldrums_string(i8*, i64) +declare %Value* @doldrums_unit() +declare %Value* @doldrums_constructor(i64, i64, i64, i8*) +declare %Value* @doldrums_thunk(%Value* (%Value**)*, i64, %Value**) +declare %Value* @doldrums_function(%Value* (%Value**)*, i64, i64, %Value**) + +; env management +declare %Value** @allocate_environment(i64) +declare %Value** @extend_environment(%Value**, i64, %Value*) + +; typeclass dispatch +declare %Value* @type_id(%Value*) + +; evaluation +declare %Value* @force(%Value*) +declare %Value* @apply(%Value*, %Value*) + +; primitives +declare %Value* @primitive_add_num(%Value*) +declare %Value* @primitive_subtract_num(%Value*) +declare %Value* @primitive_multiply_num(%Value*) +declare %Value* @primitive_divide_num(%Value*) +declare %Value* @primitive_eq_num(%Value*) +declare %Value* @primitive_neq_num(%Value*) +declare %Value* @primitive_compare_num(%Value*) +declare %Value* @primitive_putStrLn(%Value*) +declare %Value* @primitive_print(%Value*) +declare %Value* @primitive_show(%Value*) +declare %Value* @primitive_append_string(%Value*) +declare %Value* @primitive_lines(%Value*) +declare %Value* @primitive_words(%Value*) +declare %Value* @primitive_floor(%Value*) +declare %Value* @primitive_ceiling(%Value*) +declare %Value* @primitive_pure_io(%Value*) +declare %Value* @primitive_unlines(%Value*) +declare %Value* @primitive_unwords(%Value*) +declare %Value* @primitive_round(%Value*) + +""" + +buildConstructorMap :: [DataDeclaration] -> ConstructorMap +buildConstructorMap decls = + Map.fromList + [ (unTag tag, (fromIntegral idx, arity, 100 + typeIdx)) + | (typeIdx, dd) <- zip [(0 :: Int) ..] decls + , ((tag, args), idx) <- zip (declarations dd) [(0 :: Int) ..] + , let arity = Arity (length (constructorArgTypes args)) + ] + +buildStringTable :: Set Text -> StringTable +buildStringTable strs = Map.fromList + [ (s, ".str_" <> T.pack (show (i :: Int))) + | (i, s) <- zip [(0 :: Int)..] (Set.toList strs) + ] + +{- e.g. +.str_0 = private unnamed_addr constant [6 x i8] c"hello\00" +-} +genStrConst :: StringTable -> Text -> Text +genStrConst table s = + "@" <> label <> " = private unnamed_addr constant [" <> T.pack (show len) <> " x i8] c\"" <> escapeLLVM s <> "\\00\"" + where + label = table Map.! s + len = T.length s + 1 + +escapeLLVM :: Text -> Text +escapeLLVM = T.concatMap escapeChar + +escapeChar :: Char -> Text +escapeChar '\\' = "\\\\" +escapeChar '"' = "\\22" +escapeChar '\n' = "\\0A" +escapeChar '\r' = "\\0D" +escapeChar '\t' = "\\09" +escapeChar c + | fromEnum c < 32 || fromEnum c > 126 = "\\" <> T.pack (show $ fromEnum c) + | otherwise = T.singleton c -compileModule :: StgExpr -> Text -compileModule _stg = T.unlines $ concat - [ [ header ] - , [ "declare %Value* @apply(%Value*, %Value*)" - , "declare %Value* @force(%Value*)" - , "declare %Value* @mk_int(i64)" - , "declare i64 @puts(i8*)" - , "declare noalias i8* @malloc(i64)" +collectStrings :: StgExpr -> Set Text +collectStrings = \case + StgAtom a -> collectStringsAtom a + StgApp _ as -> foldMap collectStringsAtom as + StgLet bs b -> foldMap (collectStrings . stgBody) bs <> collectStrings b + StgCase a alts -> collectStringsAtom a <> foldMap f alts + where + f (StgAlt _ bs b) = foldMap (collectStrings . stgBody) bs <> collectStrings b + +collectStringsAtom :: StgAtom -> Set Text +collectStringsAtom = \case + StgAtomLit (StgLitString s) -> Set.singleton s + _ -> Set.empty + +stripLets :: StgExpr -> StgExpr +stripLets (StgLet _ b) = stripLets b +stripLets other = other + +collectAllBindings :: StgExpr -> [StgBinding] +collectAllBindings = \case + StgLet bs b -> bs <> foldMap (collectAllBindings . stgBody) bs <> collectAllBindings b + StgCase _ alts -> foldMap (\(StgAlt _ _ b) -> collectAllBindings b) alts + _ -> [] + +collectExtraNames :: StgExpr -> Set Text +collectExtraNames = \case + StgLet bs b -> + Set.fromList (concatMap stgArgs bs) + <> foldMap (collectExtraNames . stgBody) bs + <> collectExtraNames b + StgCase _ alts -> + Set.fromList (concatMap (\case StgAlt _ bs _ -> map stgName bs) alts) + <> foldMap (\(StgAlt _ _ b) -> collectExtraNames b) alts + StgAtom _ -> Set.empty + StgApp _ _ -> Set.empty + +buildNameMap :: [StgBinding] -> Set Text -> NameMap +buildNameMap bnds extraNames = + Map.fromList (bindingNames <> extraEntries) + where + bindingNames = [(stgName b, "\"doldrums_val_" <> stgName b <> "\"") | b <- bnds] + extraEntries = [(n, "\"doldrums_val_" <> n <> "\"") | n <- Set.toList extraNames] + +sanitize :: Text -> Text +sanitize = T.map $ \c -> if c == '\'' then 'p' else if c /= '_' && not (isAlphaNum c) then '_' else c + where + isAlphaNum c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') + +{- e.g. +define %Value* @stg_body_foo(%Value** %env) { +entry: + %arg_val_0 = load %Value*, %Value** %arg_ptr_0 + %forced_arg_0 = call %Value* @force(%Value* %arg_val_0) + ... + ret %Value* %result +-} +compileBinding :: StgBinding -> StringTable -> NameMap -> ConstructorMap -> Set Text -> Map Text StgExpr -> Text +compileBinding bnd strTable nameMap consMap _extraNames thunkBodyMap = + T.unlines + [ "define %Value* @" <> funcLabel <> "(%Value** %env) {" + , "entry:" + , preamble + , bodyWithRestores + , "}" , "" ] - , [ "define i64 @main() {" + where + name = stgName bnd + sname = sanitize name + funcLabel = "\"stg_body_" <> sname <> "\"" + args = stgArgs bnd + isThunk = null args + argGlobs = Set.fromList [ nameMap Map.! arg | arg <- args ] + allClosureVars = if not isThunk then Set.empty else freeVarsExpr Set.empty $ stgBody bnd + closureVarList = [ v | v <- Set.toList allClosureVars, v `Map.member` nameMap ] + loadFreeVars = + if not isThunk then "" + else T.unlines $ concat + [ [ " %fv_ptr_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env, i64 " <> T.pack (show i) + , " %fv_val_" <> T.pack (show i) <> " = load %Value*, %Value** %fv_ptr_" <> T.pack (show i) + , " store %Value* %fv_val_" <> T.pack (show i) <> ", %Value** @" <> nameMap Map.! fv + ] + | (i, fv) <- zip [(0 :: Int)..] closureVarList + ] + argGlobList = Set.toList argGlobs + globalRegName g = "%old_" <> T.filter (/= '"') g + oldSaves = if isThunk || null argGlobList + then "" + else T.unlines + [ " " <> globalRegName g <> " = load %Value*, %Value** @" <> g + | g <- argGlobList + ] + oldRestoresText = "" + argLoads = + if isThunk then [] + else concat + [ [ " %arg_ptr_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env, i64 " <> T.pack (show i) + , " %arg_val_" <> T.pack (show i) <> " = load %Value*, %Value** %arg_ptr_" <> T.pack (show i) + ] + | (i, _) <- zip [(0 :: Int) ..] args + ] + argForces = + if isThunk then [] + else concat + [ let + priorArgGlobs = Set.fromList [ nameMap Map.! a | a <- take i args ] + priorArgGlobList = Set.toList priorArgGlobs + curGlobal = nameMap Map.! argName + in + if null priorArgGlobList + then + [ " %forced_arg_" <> T.pack (show i) <> " = call %Value* @force(%Value* %arg_val_" <> T.pack (show i) <> ")" + , " store %Value* %forced_arg_" <> T.pack (show i) <> ", %Value** @" <> curGlobal + ] + else + let sfx = T.pack (show i) + curRegs = [ "%cur_" <> sfx <> "_" <> T.pack (show j) | j <- [0..length priorArgGlobList - 1] ] + curSaves = T.unlines + [ " " <> reg <> " = load %Value*, %Value** @" <> g + | (reg, g) <- zip curRegs priorArgGlobList + ] + tempRestores = T.unlines + [ " store %Value* " <> globalRegName g <> ", %Value** @" <> g + | g <- priorArgGlobList + ] + curRestores = T.unlines + [ " store %Value* " <> reg <> ", %Value** @" <> g + | (reg, g) <- zip curRegs priorArgGlobList + ] + in + [ curSaves + , tempRestores + , " %forced_arg_" <> T.pack (show i) <> " = call %Value* @force(%Value* %arg_val_" <> T.pack (show i) <> ")" + , " store %Value* %forced_arg_" <> T.pack (show i) <> ", %Value** @" <> curGlobal + , curRestores + ] + | (i, argName) <- zip [(0 :: Int) ..] args + ] + loadArgs = if isThunk then "" else T.unlines (argLoads <> argForces) + bodyText = compileBody (stgBody bnd) strTable nameMap consMap "" argGlobs thunkBodyMap + bodyWithRestores = + if isThunk || null argGlobList then bodyText + else + let + (beforeInclRet, afterRet) = T.breakOnEnd "ret " bodyText + (beforeOnly, retLine) = T.breakOnEnd "\n" (T.stripEnd beforeInclRet) + in beforeOnly <> oldRestoresText <> "\n" <> retLine <> " " <> afterRet + preamble = if isThunk then loadFreeVars else oldSaves <> "\n" <> loadArgs + +{- e.g. +define %Value* @stg_body__entry(%Value** %env) { +entry: + %env_reset_foo = call %Value** @allocate_environment(i64 1) + %t_reset_foo = call %Value* @doldrums_thunk(%Value* (%Value**)* @"stg_body_foo", i64 1, %Value** %env_reset_foo) + store %Value* %t_reset_foo, %Value** @"doldrums_val_foo" + %result = call %Value* @stg_body__entry(%Value** %env) + ret %Value* %result +} +-} +compileBodyFunc :: StgExpr -> StringTable -> NameMap -> ConstructorMap -> Map Text StgExpr -> [StgBinding] -> Text +compileBodyFunc bodyExpr strTable nameMap consMap _thunkBodyMap bnds = + let thunkBnds = [b | b <- bnds, null (stgArgs b)] + thunkResets = T.unlines $ concat + [ let sname = sanitize (stgName b) + fvSet = freeVarsExpr Set.empty (stgBody b) + allVars = [v | v <- Set.toList fvSet, v `Map.member` nameMap] + totalFvs = length allVars + hasFvs = totalFvs > 0 + envAlloc = if hasFvs + then [ " %env_reset_" <> sname <> " = call %Value** @allocate_environment(i64 " <> T.pack (show totalFvs) <> ")" ] + else [] + envStores = concat + [ [ " %env_reset_ptr_" <> sname <> "_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env_reset_" <> sname <> ", i64 " <> T.pack (show i) + , " %fv_reset_load_" <> sname <> "_" <> T.pack (show i) <> " = load %Value*, %Value** @" <> nameMap Map.! fv + , " store %Value* %fv_reset_load_" <> sname <> "_" <> T.pack (show i) <> ", %Value** %env_reset_ptr_" <> sname <> "_" <> T.pack (show i) + ] + | (i, fv) <- zip [(0 :: Int) ..] allVars + ] + envArg = if hasFvs then "%env_reset_" <> sname else "%env" + in envAlloc ++ envStores ++ + [ " %t_reset_" <> sname <> " = call %Value* @doldrums_thunk(%Value* (%Value**)* @\"stg_body_" <> sname <> "\", i64 " <> T.pack (show totalFvs) <> ", %Value** " <> envArg <> ")" + , " store %Value* %t_reset_" <> sname <> ", %Value** @" <> nameMap Map.! stgName b + ] + | b <- thunkBnds + ] + in T.unlines + [ "define %Value* @stg_body__entry(%Value** %env) {" , "entry:" - , " ret i64 0" + , thunkResets + , compileBody bodyExpr strTable nameMap consMap "" Set.empty Map.empty , "}" + , "" ] - ] -header :: Text -header = T.unlines - [ "; ModuleID = 'doldrums'" - , "target triple = \"arm64-apple-macosx15.0.0\"" - , "" - , "%Value = type { i64, i64, i64, i64 }" - , "" +compileBody :: StgExpr -> StringTable -> NameMap -> ConstructorMap -> Text -> Set Text -> Map Text StgExpr -> Text +compileBody expr strTable nameMap consMap suffix localGlobs thunkBodyMap = case expr of + StgAtom atom -> + compileAtom ("result" <> suffix) atom strTable nameMap consMap + <> "\n ret %Value* %result" <> suffix + StgApp fnName atoms + | Just rtName <- Map.lookup fnName primitives -> + compilePrimApp rtName atoms strTable nameMap consMap suffix + | fnName `Map.member` nameMap -> + compileStgApp fnName atoms strTable nameMap consMap suffix localGlobs thunkBodyMap + | fnName `Map.member` consMap -> + compileConsApp fnName atoms strTable nameMap consMap suffix localGlobs thunkBodyMap + | otherwise -> + error $ "Unknown function referenced in STG: " <> T.unpack fnName + StgLet bindings body -> + let + thunkBnds = [b | b <- bindings, null (stgArgs b)] + funcBnds = [b | b <- bindings, not (null (stgArgs b))] + letNames = Set.fromList (map stgName thunkBnds) + + orderedClosureVars bodyExpr = + let freeVarNames = Set.toList (freeVarsExpr Set.empty bodyExpr) + allVars = [ v | v <- freeVarNames, v `Map.member` nameMap ] + siblingIndices = [i | (i, v) <- zip [(0 :: Int) ..] allVars, v `Set.member` letNames] + in (allVars, siblingIndices) + + genThunkInit b = + let sname = sanitize (stgName b) + (allVars, siblingIndices) = orderedClosureVars (stgBody b) + totalFvs = length allVars + hasFvs = totalFvs > 0 + siblingSet = Set.fromList siblingIndices + + envAlloc = if hasFvs + then [ " %env_" <> sname <> " = call %Value** @allocate_environment(i64 " <> T.pack (show totalFvs) <> ")" ] + else [] + + envStores = concat + [ [ " %env_ptr_" <> sname <> "_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env_" <> sname <> ", i64 " <> T.pack (show i) + , " %fv_load_" <> sname <> "_" <> T.pack (show i) <> " = load %Value*, %Value** @" <> nameMap Map.! fv + , " store %Value* %fv_load_" <> sname <> "_" <> T.pack (show i) <> ", %Value** %env_ptr_" <> sname <> "_" <> T.pack (show i) + ] + | (i, fv) <- zip [(0 :: Int) ..] allVars + , i `Set.notMember` siblingSet + ] + + envArg = if hasFvs + then "%env_" <> sname + else "null" + thunkCreate = + [ " %t_" <> sname <> " = call %Value* @doldrums_thunk(%Value* (%Value**)* @\"stg_body_" <> sname <> "\", i64 " <> T.pack (show totalFvs) <> ", %Value** " <> envArg <> ")" + , " store %Value* %t_" <> sname <> ", %Value** @" <> nameMap Map.! stgName b + ] + + fixups = concat + [ [ " %fix_ptr_" <> sname <> "_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env_" <> sname <> ", i64 " <> T.pack (show i) + , " %fix_load_" <> sname <> "_" <> T.pack (show i) <> " = load %Value*, %Value** @" <> nameMap Map.! fv + , " store %Value* %fix_load_" <> sname <> "_" <> T.pack (show i) <> ", %Value** %fix_ptr_" <> sname <> "_" <> T.pack (show i) + ] + | (i, fv) <- zip [(0 :: Int) ..] allVars + , i `Set.member` siblingSet + ] + + in (envAlloc, envStores, thunkCreate, fixups) + + thunkPhaseData = map genThunkInit thunkBnds + allEnvAlloc = concatMap (\(a,_,_,_) -> a) thunkPhaseData + allEnvStores = concatMap (\(_,b,_,_) -> b) thunkPhaseData + allThunkCreate = concatMap (\(_,_,c,_) -> c) thunkPhaseData + allFixups = concatMap (\(_,_,_,d) -> d) thunkPhaseData + thunkInit = concat [allEnvAlloc, allEnvStores, allThunkCreate, allFixups] + + funcInit = concat + [ [ " %t_" <> sname <> " = call %Value* @doldrums_function(%Value* (%Value**)* @\"stg_body_" <> sname <> "\", i64 " <> T.pack (show (length (stgArgs b))) <> ", i64 0, %Value** null)" + , " store %Value* %t_" <> sname <> ", %Value** @" <> nameMap Map.! stgName b + ] + | b <- funcBnds + , let sname = sanitize (stgName b) + ] + newGlobs = Set.fromList [ nameMap Map.! stgName b | b <- bindings, stgName b `Map.member` nameMap ] + extendedGlobs = localGlobs `Set.union` newGlobs + letComment = if null thunkInit && null funcInit then "" else "; Let bindings\n" + in T.unlines (letComment : (thunkInit ++ funcInit)) + <> "\n" <> compileBody body strTable nameMap consMap suffix extendedGlobs thunkBodyMap + StgCase scrutAtom alts -> + compileCase scrutAtom alts strTable nameMap consMap suffix localGlobs thunkBodyMap + +primitives :: Map Text Text +primitives = Map.fromList + [ ("+", "primitive_add_num") + , ("-", "primitive_subtract_num") + , ("*", "primitive_multiply_num") + , ("/", "primitive_divide_num") + , ("==", "primitive_eq_num") + , ("/=", "primitive_neq_num") + , ("compare", "primitive_compare_num") + , ("putStrLn", "primitive_putStrLn") + , ("print", "primitive_print") + , ("show", "primitive_show") + , ("<>", "primitive_append_string") + , ("lines", "primitive_lines") + , ("words", "primitive_words") + , ("floor", "primitive_floor") + , ("ceiling", "primitive_ceiling") + , ("pure", "primitive_pure_io") + , ("unlines", "primitive_unlines") + , ("unwords", "primitive_unwords") + , ("round", "primitive_round") + , ("__type_id__", "type_id") ] --- | Generates LLVM code from STG, then runs the program with help from a runtime code file, and returns its output as @Text@ -compileAndRun :: StgExpr -> FilePath -> IO Text -compileAndRun stg runtimePath = do - let llvmIR = compileModule stg - withSystemTempDirectory "doldrums" $ \tmpDir -> do - let llPath = tmpDir <> "/program.ll" - objPath = tmpDir <> "/program.o" - binPath = tmpDir <> "/program" - TIO.writeFile llPath llvmIR - - (ec1, out1, err1) <- readProcessWithExitCode "clang" - [ "-c", llPath, "-o", objPath ] "" - when (ec1 /= ExitSuccess) $ - error $ "LLVM assembly failed: " <> err1 <> "\n" <> out1 - - let runtimeObj = tmpDir <> "/runtime.o" - (ec2, _, err2) <- readProcessWithExitCode "clang" - [ "-c", runtimePath, "-o", runtimeObj ] "" - when (ec2 /= ExitSuccess) $ - error $ "Runtime compilation failed: " <> err2 - - (ec3, _, err3) <- readProcessWithExitCode "clang" - [ objPath, runtimeObj, "-o", binPath ] "" - when (ec3 /= ExitSuccess) $ - error $ "Linking failed: " <> err3 - - (ec4, out, err4) <- readProcessWithExitCode binPath [] "" - when (ec4 /= ExitSuccess) $ - error $ "Runtime error: " <> err4 - - pure $ T.pack out +{- e.g. +%arg0 = load %Value*, %Value** @"doldrums_val_x" +%result0 = call %Value* @primitive_add_num(%Value* %arg0) +ret %Value* %result0 +-} +compilePrimApp :: Text -> [StgAtom] -> StringTable -> NameMap -> ConstructorMap -> Text -> Text +compilePrimApp rtName atoms strTable nameMap consMap suffix = case atoms of + [a] -> + T.unlines + [ compileAtom ("arg" <> suffix) a strTable nameMap consMap + , " %result" <> suffix <> " = call %Value* @" <> rtName <> "(%Value* %arg" <> suffix <> ")" + , " ret %Value* %result" <> suffix + ] + _ -> error $ "Primitive expects 1 argument, got " <> show (length atoms) + +wrapWithSaveRestore :: Text -> Set Text -> Text -> Text +wrapWithSaveRestore suffix localGlobs body = + let globList = Set.toList localGlobs + in if null globList + then body + else + let savedRegs = [ "%saved_" <> suffix <> "_" <> T.pack (show i) | i <- [0..length globList - 1] ] + saves = T.unlines + [ " " <> reg <> " = load %Value*, %Value** @" <> g + | (reg, g) <- zip savedRegs globList + ] + restores = T.unlines + [ " store %Value* " <> reg <> ", %Value** @" <> g + | (reg, g) <- zip savedRegs globList + ] + (beforeInclRet, afterRet) = T.breakOnEnd "ret " body + (beforeOnly, retLine) = T.breakOnEnd "\n" (T.stripEnd beforeInclRet) + in saves <> "\n" <> beforeOnly <> restores <> "\n" <> retLine <> " " <> afterRet + +{- e.g. +%fn0 = load %Value*, %Value** @"doldrums_val_f" +%result0 = call %Value* @force(%Value* %fn0) +ret %Value* %result0 +-} +compileStgApp :: Text -> [StgAtom] -> StringTable -> NameMap -> ConstructorMap -> Text -> Set Text -> Map Text StgExpr -> Text +compileStgApp fnName atoms strTable nameMap consMap suffix localGlobs _thunkBodyMap = case atoms of + [] -> + wrapWithSaveRestore suffix localGlobs $ T.unlines + [ " %fn" <> suffix <> " = load %Value*, %Value** @" <> global + , " %result" <> suffix <> " = call %Value* @force(%Value* %fn" <> suffix <> ")" + , " ret %Value* %result" <> suffix + ] + [a] -> + wrapWithSaveRestore suffix localGlobs $ T.unlines + [ compileAtom ("arg" <> suffix) a strTable nameMap consMap + , " %fn" <> suffix <> " = load %Value*, %Value** @" <> global + , " %result" <> suffix <> " = call %Value* @apply(%Value* %fn" <> suffix <> ", %Value* %arg" <> suffix <> ")" + , " ret %Value* %result" <> suffix + ] + _ -> error "Multi-arg StgApp not yet supported" + where + global = nameMap Map.! fnName + +{- e.g. +%cons0 = call %Value* @doldrums_constructor(i64 1, i64 2, i64 100, i8* getelementptr inbounds ([4 x i8], [4 x i8]* @.str_0, i64 0, i64 0)) +%result0 = call %Value* @apply(%Value* %cons0, %Value* %arg0) +ret %Value* %result0 +-} +compileConsApp :: Text -> [StgAtom] -> StringTable -> NameMap -> ConstructorMap -> Text -> Set Text -> Map Text StgExpr -> Text +compileConsApp fnName atoms strTable nameMap consMap suffix localGlobs _thunkBodyMap = + let (consTag, Arity arity, typeTag) = consMap Map.! fnName + label = strTable Map.! fnName + len = T.length fnName + mkCons = " %cons" <> suffix <> " = call %Value* @doldrums_constructor(i64 " <> T.pack (show consTag) <> ", i64 " <> T.pack (show arity) <> ", i64 " <> T.pack (show typeTag) <> ", i8* getelementptr inbounds ([" <> T.pack (show (len+1)) <> " x i8], [" <> T.pack (show (len+1)) <> " x i8]* @" <> label <> ", i64 0, i64 0))" + in case atoms of + [] -> T.unlines + [ mkCons + , " ret %Value* %cons" <> suffix + ] + [a] -> + wrapWithSaveRestore suffix localGlobs $ T.unlines + [ compileAtom ("arg" <> suffix) a strTable nameMap consMap + , mkCons + , " %result" <> suffix <> " = call %Value* @apply(%Value* %cons" <> suffix <> ", %Value* %arg" <> suffix <> ")" + , " ret %Value* %result" <> suffix + ] + _ -> error "Multi-arg constructor application not yet supported" + +{- e.g. +%scrut0 = load %Value*, %Value** @"doldrums_val_x" +%scrut_f0 = call %Value* @force(%Value* %scrut0) +%scrut_val0 = load %Value, %Value* %scrut_f0 +%scrut_tag_raw0 = extractvalue %Value %scrut_val0, 1 +switch i64 %scrut_tag0, label %else0 [i64 1, label %alt_Just0] +-} +compileCase :: StgAtom -> [StgAlt] -> StringTable -> NameMap -> ConstructorMap -> Text -> Set Text -> Map Text StgExpr -> Text +compileCase scrutAlts alts strTable nameMap consMap suffix localGlobs thunkBodyMap = + let globList = Set.toList localGlobs + (saves, restores) = if null globList + then ([], []) + else + let savedRegs = [ "%saved_case_" <> suffix <> "_" <> T.pack (show i) | i <- [0..length globList - 1] ] + in ( [ " " <> reg <> " = load %Value*, %Value** @" <> g | (reg, g) <- zip savedRegs globList ] + , [ " store %Value* " <> reg <> ", %Value** @" <> g | (reg, g) <- zip savedRegs globList ] + ) + in T.unlines $ concat + [ [ "; Case expression" ] + , T.lines (compileAtom ("scrut" <> suffix) scrutAlts strTable nameMap consMap) + , saves + , [ " %scrut_f" <> suffix <> " = call %Value* @force(%Value* %scrut" <> suffix <> ")" + ] + , restores + , [ " %scrut_val" <> suffix <> " = load %Value, %Value* %scrut_f" <> suffix + , " %scrut_tag_raw" <> suffix <> " = extractvalue %Value %scrut_val" <> suffix <> ", 1" + , " %scrut_tag" <> suffix <> " = and i64 %scrut_tag_raw" <> suffix <> ", 4294967295" + ] + , caseAlts + ] + + where + constructorAlts = [(tag, bs, body) | StgAlt (Just tag) bs body <- alts] + defaultAlts = [(bs, body) | StgAlt Nothing bs body <- alts] + + caseAlts = case defaultAlts of + [] -> genSwitch constructorAlts + (def:_) -> genSwitchWithDefault constructorAlts def + + genSwitch :: [(Tag, [StgBinding], StgExpr)] -> [Text] + genSwitch alts' = + let entries = mapMaybe (\(tag, _, _) -> + case Map.lookup (unTag tag) consMap of + Just (n, _, _) -> Just (" i64 " <> T.pack (show n) <> ", label %alt_" <> unTag tag <> suffix) + Nothing -> Nothing + ) alts' + bodies = concatMap (\(tag, bs, body) -> genAltBody tag bs body) alts' + in if null entries + then [ " unreachable" ] + else [ " switch i64 %scrut_tag" <> suffix <> ", label %else" <> suffix <> " [" ] + <> entries + <> [ " ]" ] + <> [ "else" <> suffix <> ":" ] + <> [ " unreachable" ] + <> bodies + + genSwitchWithDefault :: [(Tag, [StgBinding], StgExpr)] -> ([StgBinding], StgExpr) -> [Text] + genSwitchWithDefault constrAlts (defBs, defBody) = + let entries = mapMaybe (\(tag, _, _) -> + case Map.lookup (unTag tag) consMap of + Just (n, _, _) -> Just (" i64 " <> T.pack (show n) <> ", label %alt_" <> unTag tag <> suffix) + Nothing -> Nothing + ) constrAlts + bodies = concatMap (\(tag, bs, body) -> genAltBody tag bs body) constrAlts + scrutVar = "%scrut_f" <> suffix + defNewGlobs = Set.fromList [ nameMap Map.! stgName b | b <- defBs, stgName b `Map.member` nameMap ] + defGlobs = localGlobs `Set.union` defNewGlobs + in [ " switch i64 %scrut_tag" <> suffix <> ", label %def_alt" <> suffix <> " [" ] + <> entries + <> [ " ]" ] + <> [ "def_alt" <> suffix <> ":" ] + <> [ " store %Value* " <> scrutVar <> ", %Value** @" <> nameMap Map.! stgName b + | b <- defBs + , stgName b `Map.member` nameMap + ] + <> T.lines (compileBody defBody strTable nameMap consMap (suffix <> "_def") defGlobs thunkBodyMap) + <> bodies + + genAltBody :: Tag -> [StgBinding] -> StgExpr -> [Text] + genAltBody tag bs body = + let tagSuffix = unTag tag + nestedSuffix = suffix <> "_" <> tagSuffix + altNewGlobs = Set.fromList [ nameMap Map.! stgName b | b <- bs, stgName b `Map.member` nameMap ] + altGlobs = localGlobs `Set.union` altNewGlobs + in [ "alt_" <> tagSuffix <> suffix <> ":" ] + <> [ " %alt_args" <> suffix <> " = extractvalue %Value %scrut_val" <> suffix <> ", 3" + | not (null bs) + ] <> [ " %aa_base" <> suffix <> " = inttoptr i64 %alt_args" <> suffix <> " to %Value**" + | not (null bs) + ] <> concat + [ [ " %aa_ptr_" <> T.pack (show i) <> "_" <> tagSuffix <> suffix <> " = getelementptr inbounds %Value*, %Value** %aa_base" <> suffix <> ", i64 " <> T.pack (show (i + 1)) + , " %aa_val_" <> T.pack (show i) <> "_" <> tagSuffix <> suffix <> " = load %Value*, %Value** %aa_ptr_" <> T.pack (show i) <> "_" <> tagSuffix <> suffix + , " store %Value* %aa_val_" <> T.pack (show i) <> "_" <> tagSuffix <> suffix <> ", %Value** @" <> nameMap Map.! stgName b + ] + | (i, b) <- zip [(0 :: Int)..] bs + , stgName b `Map.member` nameMap + ] + <> T.lines (compileBody body strTable nameMap consMap nestedSuffix altGlobs thunkBodyMap) + +{- e.g. +%x0 = call %Value* @doldrums_int(i64 42) +; or +%x1 = load %Value*, %Value** @"doldrums_val_foo" +-} +compileAtom :: Text -> StgAtom -> StringTable -> NameMap -> ConstructorMap -> Text +compileAtom reg atom strTable nameMap consMap = case atom of + StgAtomLit (StgLitInt n) -> + " %" <> reg <> " = call %Value* @doldrums_int(i64 " <> T.pack (show n) <> ")" + StgAtomLit (StgLitDouble d) -> + " %" <> reg <> " = call %Value* @doldrums_double(i64 bitcast (double " <> T.pack (show d) <> " to i64))" + StgAtomLit (StgLitString s) -> + let label = strTable Map.! s + len = T.length s + in " %" <> reg <> " = call %Value* @doldrums_string(i8* getelementptr inbounds ([" <> T.pack (show (len+1)) <> " x i8], [" <> T.pack (show (len+1)) <> " x i8]* @" <> label <> ", i64 0, i64 0), i64 " <> T.pack (show len) <> ")" + StgAtomVar varName + | Just (consTag, Arity arity, typeTag) <- Map.lookup varName consMap -> + let label = strTable Map.! varName + len = T.length varName + in " %" <> reg <> " = call %Value* @doldrums_constructor(i64 " <> T.pack (show consTag) <> ", i64 " <> T.pack (show arity) <> ", i64 " <> T.pack (show typeTag) <> ", i8* getelementptr inbounds ([" <> T.pack (show (len+1)) <> " x i8], [" <> T.pack (show (len+1)) <> " x i8]* @" <> label <> ", i64 0, i64 0))" + | Just g <- Map.lookup varName nameMap -> + " %" <> reg <> " = load %Value*, %Value** @" <> g + | otherwise -> + error $ "Unknown variable: " <> T.unpack varName + +{- e.g. +define %Value* @doldrums_entry() { + %t_foo = call %Value* @doldrums_function(%Value* (%Value**)* @"stg_body_foo", i64 1, i64 0, %Value** %null_env_ptr) + store %Value* %t_foo, %Value** @"doldrums_val_foo" + %result = call %Value* @stg_body__entry(%Value** %null_env_ptr) + ret %Value* %result +} +globals: @"doldrums_val_foo" = global %Value* null +-} +entryPoint :: NameMap -> Map Text Int -> Set Text -> [StgBinding] -> Text +entryPoint nameMap bindingArities _noThunkNames bnds = + let nameToGlobal name = nameMap Map.! name + thunkInits = T.unlines $ concat + [ case Map.lookup (stgName b) bindingArities of + Just arity -> + let sname = sanitize (stgName b) + g = nameToGlobal (stgName b) + in [ " %t_" <> sname <> " = call %Value* @doldrums_function(%Value* (%Value**)* @\"stg_body_" <> sname <> "\", i64 " <> T.pack (show arity) <> ", i64 0, %Value** %null_env_ptr)" + , " store %Value* %t_" <> sname <> ", %Value** @" <> g + ] + Nothing -> + let sname = sanitize (stgName b) + g = nameToGlobal (stgName b) + fvSet = freeVarsExpr Set.empty (stgBody b) + allVars = [v | v <- Set.toList fvSet, v `Map.member` nameMap] + totalFvs = length allVars + hasFvs = totalFvs > 0 + envAlloc = if hasFvs + then [ " %env_init_" <> sname <> " = call %Value** @allocate_environment(i64 " <> T.pack (show totalFvs) <> ")" ] + else [] + envStores = concat + [ [ " %env_init_ptr_" <> sname <> "_" <> T.pack (show i) <> " = getelementptr inbounds %Value*, %Value** %env_init_" <> sname <> ", i64 " <> T.pack (show i) + , " %fv_init_load_" <> sname <> "_" <> T.pack (show i) <> " = load %Value*, %Value** @" <> nameMap Map.! fv + , " store %Value* %fv_init_load_" <> sname <> "_" <> T.pack (show i) <> ", %Value** %env_init_ptr_" <> sname <> "_" <> T.pack (show i) + ] + | (i, fv) <- zip [(0 :: Int) ..] allVars + ] + envArg = if hasFvs then "%env_init_" <> sname else "%null_env_ptr" + in envAlloc ++ envStores ++ + [ " %t_" <> sname <> " = call %Value* @doldrums_thunk(%Value* (%Value**)* @\"stg_body_" <> sname <> "\", i64 " <> T.pack (show totalFvs) <> ", %Value** " <> envArg <> ")" + , " store %Value* %t_" <> sname <> ", %Value** @" <> g + ] + | b <- bnds + ] + globals = T.unlines + [ "@" <> g <> " = global %Value* null" | g <- Map.elems nameMap ] + in T.unlines $ concat + [ [ "define %Value* @doldrums_entry() {" + , " %null_env = alloca [0 x %Value*], align 8" + , " %null_env_ptr = getelementptr inbounds [0 x %Value*], [0 x %Value*]* %null_env, i64 0, i64 0" + ] + , T.lines thunkInits + , [ " %result = call %Value* @stg_body__entry(%Value** %null_env_ptr)" + , " %result_f = call %Value* @force(%Value* %result)" + , " ret %Value* %result_f" + , "}" + , "" + ] + , T.lines globals + ] + +mainFunc :: Text +mainFunc = T.pack """ +define i32 @main(i32 %argc, i8** %argv) { + %_ = call %Value* @doldrums_entry() + ret i32 0 +} +""" diff --git a/src/Language.hs b/src/Language.hs index 59906c5..7fb23d9 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -258,11 +258,10 @@ collectArgs (AnnExprApplication _ f x) = collectArgs e = (e, []) lookupTag :: [DataDeclaration] -> Tag -> Arity -lookupTag [] tag = error $ "Could not find constructor: " <> show tag -lookupTag (DataDeclaration [] _dataType _typeParams _deriv : rest) tag = lookupTag rest tag -lookupTag (DataDeclaration ((x, args):xs) dataType typeParams deriv : rest) tag - | tag == x = Arity $ length args - | otherwise = lookupTag (DataDeclaration xs dataType typeParams deriv : rest) tag +lookupTag dds tag = + case lookup tag (concatMap declarations dds) of + Just args -> Arity $ length args + Nothing -> error $ "Could not find constructor: " <> show tag patternToLambda :: a -> Pattern -> AnnotatedExpr a -> AnnotatedExpr a patternToLambda annot (PatternVar n) body = AnnExprLambda annot n body diff --git a/src/Lib.hs b/src/Lib.hs index 4aecff9..0c66c2d 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -16,6 +16,7 @@ import Typecheck import FixAst (fixAst) import Interpret (interpret, methodEnvFromInstances) import STG (compileStg) +import LLVM (compileLLVM, runLLVM) import Data.Text (Text, pack, unpack) import qualified Data.Text as Text import Control.Monad (when, unless) @@ -72,7 +73,9 @@ executeFull programText debugFlag compileFlag = do reportHoles programText (typeInstantiationSubstitution state) holes exitFailure - let stgExpr = compileStg program + let progUnit = fmap (const ()) program + progWithInstanceMethods = addInstanceMethodsAsFunctions progUnit + stgExpr = compileStg progWithInstanceMethods debug debugFlag "STG" $ do let stgExprStr = show stgExpr charLimit = 1000 @@ -83,10 +86,12 @@ executeFull programText debugFlag compileFlag = do when bigger $ putStrLn $ "[...plus " <> show (length stgExprStr - charLimit) <> " more characters]" - debug debugFlag "OUTPUT" $ pure () case compileFlag of Compiled -> do - error "Compilation to LLVM IR is still a work in progress" + let llvmText = compileLLVM stgExpr $ dataDeclarations program + debug debugFlag "LLVM" $ putTextLn llvmText + debug debugFlag "OUTPUT" $ pure () + runLLVM llvmText Interpreted -> do let @@ -101,8 +106,119 @@ executeFull programText debugFlag compileFlag = do , (tag, _) <- declarations dtDecl ] methodEnv = methodEnvFromInstances (instanceDeclarations prog) typeMap + debug debugFlag "OUTPUT" $ pure () interpret topLevelBindings methodEnv typeMap mainExpr +addInstanceMethodsAsFunctions :: Program () -> Program () +addInstanceMethodsAsFunctions prog@Program{..} = + prog { functions = functions <> instanceMethodFunctions <> dispatchFunctions } + where + typeCtorTags = buildDataTypeCtorTags dataDeclarations + methodInstances = Map.fromListWith (<>) + [ (unName methodName, [(mangleName methodName ty, typeIdForHint ty, ty)]) + | InstanceDeclaration{..} <- instanceDeclarations + , (methodName, _) <- instanceMethods + , unName methodName `notElem` primitiveMethods + , ty <- instanceTypes + ] + instanceMethodFunctions = + [ Function () (mangleName methodName ty) (map PatternVar argNames) body + | InstanceDeclaration{..} <- instanceDeclarations + , (methodName, bodyExpr) <- instanceMethods + , unName methodName `notElem` primitiveMethods + , ty <- instanceTypes + , let (argNames, body) = collectMethodArgs bodyExpr + ] + dispatchFunctions = + [ genDispatch methodName entries + | (methodName, entries) <- Map.toList methodInstances + ] + +genDispatch :: Text -> [(Name, Integer, TypeHint)] -> Function () +genDispatch _methodName entries = + let argName = Name "__arg__" + in Function () (Name _methodName) [PatternVar argName] (buildDispatch entries (AnnExprVariable () argName)) + +buildDispatch :: [(Name, Integer, TypeHint)] -> Expr -> Expr +buildDispatch [] _ = error "buildDispatch: empty entries list" +buildDispatch [(mangledName, _typeId, _hint)] arg = + AnnExprApplication () (AnnExprVariable () mangledName) arg +buildDispatch ((mangledName, typeId, _hint):rest) arg = + let checkExpr = AnnExprApplication () + (AnnExprApplication () (AnnExprVariable () (Name "==")) + (AnnExprApplication () (AnnExprVariable () (Name "__type_id__")) arg)) + (AnnExprLiteral () (LiteralInt typeId)) + in AnnExprCase () checkExpr + [ Alternative (PatternConstructor (Tag "True") []) + (AnnExprApplication () (AnnExprVariable () mangledName) arg) + , Alternative (PatternVar (Name "_")) + (buildDispatch rest arg) + ] + +typeIdForHint :: TypeHint -> Integer +typeIdForHint TypeHintInt = 0 +typeIdForHint TypeHintString = 1 +typeIdForHint TypeHintDouble = 2 +typeIdForHint (TypeHintConstructor dt) = + let typeName = unDataType dt + tags = case Map.lookup typeName typeCtorTags of + Just ts -> ts + Nothing -> error $ "Unknown data type: " <> unpack typeName + in 100 + toInteger (minimum tags) +typeIdForHint (TypeHintApp (TypeHintConstructor dt) _) = + let typeName = unDataType dt + tags = case Map.lookup typeName typeCtorTags of + Just ts -> ts + Nothing -> error $ "Unknown data type: " <> unpack typeName + in 100 + toInteger (minimum tags) +typeIdForHint _ = error "Unknown type hint for method dispatch" + +buildDataTypeCtorTags :: [DataDeclaration] -> Map.Map Text [Int] +buildDataTypeCtorTags decls = + Map.fromListWith (<>) + [ (unDataType (dataType dd), [globalIdx]) + | (globalIdx, (dd, _)) <- zip [0..] [(dd, c) | dd <- decls, c <- declarations dd] + ] + +collectMethodArgs :: Expr -> ([Name], Expr) +collectMethodArgs (ExprLambda n e) = let (ns, b) = collectMethodArgs e in (n:ns, b) +collectMethodArgs e = ([], e) + +mangleName :: Name -> TypeHint -> Name +mangleName (Name n) hint = Name (n <> "_" <> typeTagFromHint hint) + +typeTagFromHint :: TypeHint -> Text +typeTagFromHint TypeHintInt = "Int" +typeTagFromHint TypeHintDouble = "Double" +typeTagFromHint TypeHintString = "String" +typeTagFromHint (TypeHintConstructor dt) = unDataType dt +typeTagFromHint (TypeHintApp (TypeHintConstructor dt) _) = unDataType dt +typeTagFromHint (TypeHintVar _) = "var" +typeTagFromHint _ = "unknown" + +primitiveMethods :: [Text] +primitiveMethods = + [ "show" + , "<>" + , "==" + , "/=" + , "compare" + , "+" + , "-" + , "*" + , "/" + , "print" + , "putStrLn" + , "lines" + , "words" + , "floor" + , "ceiling" + , "unlines" + , "unwords" + , "round" + , "pure" + ] + -- | Given source code @Text@, typechecks a Doldrums program, but doesn't actually execute it typecheckOnly :: Text -> DebugFlag -> IO (Either Text Type) typecheckOnly programText debugFlag = do diff --git a/src/Prelude.dol b/src/Prelude.dol index 311599f..e48afce 100644 --- a/src/Prelude.dol +++ b/src/Prelude.dol @@ -230,6 +230,10 @@ splitAt n xs (y:ys) -> case splitAt (n - 1) ys of (as, bs) -> (y:as, bs) +fst (Tuple2 a _) = a + +snd (Tuple2 _ b) = b + -- numbers add x y = x + y multiply x y = x * y diff --git a/src/STG.hs b/src/STG.hs index 79ad964..28f93db 100644 --- a/src/STG.hs +++ b/src/STG.hs @@ -1,10 +1,9 @@ -module STG - (compileStg, StgExpr(..)) -where +module STG where import Language import FixAst (singleExprForm) import Control.Monad.State +import Data.List (partition) import Data.Text (Text) import qualified Data.Text as Text import Data.Set (Set) @@ -38,7 +37,7 @@ data StgBinding = StgBinding , stgBody :: StgExpr } deriving (Show) -data StgAlt = StgAlt [StgBinding] StgExpr +data StgAlt = StgAlt (Maybe Tag) [StgBinding] StgExpr deriving (Show) -- | Lower a 'Program' to STG (spineless tagless G-machine) representation. This is an intermediate step between 'Expr' and LLVM IR @@ -74,10 +73,26 @@ toStg e = case e of stgBody <- toStg body pure $ StgLet [StgBinding name [] (map unName args) stgBody] (StgAtom (StgAtomVar name)) - ExprCase scrutinee alts -> do - (scrutAtom, scrutBinds) <- atomize scrutinee - stgAlts <- mapM toStgAlt alts - pure . StgLet scrutBinds $ StgCase scrutAtom stgAlts + ExprCase scrutinee alts + | any isLitAlt alts -> toStg $ buildLiteralCase scrutinee litAlts otherAlts + | otherwise -> do + (scrutAtom, scrutBinds) <- atomize scrutinee + stgAlts <- mapM toStgAlt alts + pure . StgLet scrutBinds $ StgCase scrutAtom stgAlts + where + isLitAlt (Alternative (PatternLiteral _) _) = True + isLitAlt _ = False + (litAlts, otherAlts) = partition isLitAlt alts + + buildLiteralCase :: Expr -> [CaseAlternative ()] -> [CaseAlternative ()] -> Expr + buildLiteralCase scrut [] other = ExprCase scrut other + buildLiteralCase scrut ((Alternative (PatternLiteral lit) body) : rest) other = + let eqExpr = ExprApplication (ExprApplication (ExprVariable (Name "==")) scrut) (ExprLiteral lit) + in ExprCase eqExpr + [ Alternative (PatternConstructor (Tag "True") []) body + , Alternative (PatternVar (Name "_")) (buildLiteralCase scrut rest other) + ] + buildLiteralCase _ _ _ = error "buildLiteralCase: unexpected alternative" ExprApplication f a -> do (fAtom, fBinds) <- atomize f (aAtom, aBinds) <- atomize a @@ -92,7 +107,10 @@ toStgAlt (Alternative pat body) = do stgBody <- toStg body let pvars = patternNames pat bindings = [StgBinding (unName v) [] [] (StgAtom . StgAtomVar $ unName v) | v <- pvars] - pure $ StgAlt bindings stgBody + tag = case pat of + PatternConstructor t _ -> Just t + _ -> Nothing + pure $ StgAlt tag bindings stgBody atomize :: Expr -> State Int (StgAtom, [StgBinding]) atomize = \case @@ -128,9 +146,9 @@ annotateFreeVars bound = \case freeVars = Set.toList $ Set.difference (freeVarsExpr localBound $ stgBody binding) bound in binding { stgFreeVars = freeVars } - annotateAlt (StgAlt bindings body) = + annotateAlt (StgAlt tag bindings body) = let altBound = Set.union bound . Set.fromList $ map stgName bindings - in StgAlt bindings $ annotateFreeVars altBound body + in StgAlt tag bindings $ annotateFreeVars altBound body freeVarsExpr :: Set StgName -> StgExpr -> Set StgName freeVarsExpr bound = \case @@ -149,7 +167,7 @@ freeVarsExpr bound = \case freeVarsAtom atom `Set.difference` bound <> foldMap f alts where - f (StgAlt bindings body) = + f (StgAlt _ bindings body) = freeVarsExpr (Set.union bound . Set.fromList $ map stgName bindings) body freeVarsAtom :: StgAtom -> Set StgName @@ -160,5 +178,5 @@ freeVarsAtom = \case freshName :: State Int StgName freshName = do n <- get - put (n + 1) + put $ n + 1 pure $ "stg_" <> Text.pack (show n) diff --git a/src/Typecheck.hs b/src/Typecheck.hs index ab69f31..0219cc1 100644 --- a/src/Typecheck.hs +++ b/src/Typecheck.hs @@ -458,7 +458,6 @@ typeHintToType = \case TypeHintVar n -> TypeVariable n TypeHintConstructor dt -> TypeTagged dt TypeHintApp (TypeHintConstructor dt) _ -> TypeTagged dt - TypeHintApp (TypeHintVar n) args -> foldl TypeAp (TypeVariable n) (map typeHintToType args) TypeHintApp first args -> foldl TypeAp (typeHintToType first) (map typeHintToType args) a :~> b -> typeHintToType a :-> typeHintToType b TypeHintConstraint _ body -> typeHintToType body @@ -530,15 +529,13 @@ typeInferenceWithIO requireIO program programText = do ] initialFunctionTypes :: Program SourcePos -> Int -> [(Name, Scheme)] - initialFunctionTypes (Program [] [] _ _ _) _ = [] - initialFunctionTypes (Program (Function _ name args _ : restFuncs) datas sigs cls instances) n = - (name, Scheme [] [] $ functionType n (Arity $ length args) Nothing) - : initialFunctionTypes (Program restFuncs datas sigs cls instances) (n+1) - initialFunctionTypes (Program funcs (DataDeclaration [] _dataTy _typeParams _ : restDatas) sigs cls instances) n = - initialFunctionTypes (Program funcs restDatas sigs cls instances) n - initialFunctionTypes (Program funcs (DataDeclaration ((x, args) : restDecls) dataTy typeParams deriv : restDatas) sigs cls instances) n = - (Name $ unTag x, constructorScheme typeParams (constructorArgTypes args) dataTy) - : initialFunctionTypes (Program funcs (DataDeclaration restDecls dataTy typeParams deriv : restDatas) sigs cls instances) (n+1) + initialFunctionTypes prog n = + zipWith (\f i -> (name f, Scheme [] [] $ functionType i (Arity $ length (args f)) Nothing)) + (functions prog) [n..] + <> [ (Name $ unTag tag, constructorScheme (typeParameters dd) (constructorArgTypes args) (dataType dd)) + | dd <- dataDeclarations prog + , (tag, args) <- declarations dd + ] constructorScheme :: [Name] -> [TypeRef] -> DataType -> Scheme constructorScheme typeParams typeRefs dataTy = diff --git a/test/Parser.hs b/test/Parser.hs index 1e0f2fc..89a994f 100644 --- a/test/Parser.hs +++ b/test/Parser.hs @@ -32,7 +32,7 @@ testParserFail parser input = parse parser "" input `shouldSatisfy` isLeft parserSpec :: Spec -parserSpec = describe "parsing" $ do +parserSpec = parallel $ describe "parsing" $ do it "parseInt" $ do testParser parseExprLiteral "42" (ExprLiteral (LiteralInt 42)) testParser parseExprLiteral "0" (ExprLiteral (LiteralInt 0)) diff --git a/test/Spec.hs b/test/Spec.hs index eb4ffe8..ee1d76b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -17,12 +17,13 @@ import qualified Data.Text as T import Test.Hspec import Control.Exception (try, SomeException) import System.Timeout (timeout) - -import System.Directory (listDirectory) -import System.FilePath ((), takeExtension, dropExtension) +import System.Directory (listDirectory, removeDirectoryRecursive, doesDirectoryExist, removeFile, createDirectoryIfMissing) +import System.Exit (ExitCode(..)) +import System.FilePath ((), takeExtension, takeFileName, dropExtension) +import System.Process (readProcessWithExitCode) main :: IO () -main = hspec $ do +main = hspec $ afterAll cleanup $ beforeAll setup $ do -- test how the parser handles pieces smaller than an entire program parserSpec @@ -31,14 +32,14 @@ main = hspec $ do -- test programs that should work and produce a specified output -- these programs start with a comment like: -- -- EXPECT output - describe "expect tests" $ do + parallel . describe "expect tests" $ do files <- runIO $ discoverDolFiles "test/expect" mapM_ mkDolTest files -- test programs that should not work -- these programs start with: -- -- BROKEN - describe "broken program tests" $ do + parallel . describe "broken program tests" $ do files <- runIO $ discoverDolFiles "test/broken" mapM_ mkDolTest files @@ -48,6 +49,30 @@ main = hspec $ do content <- TIO.readFile "tour.dol" void $ execute content NoDebugInfo Interpreted +setup :: IO () +setup = do + -- recompile library to link against + createDirectoryIfMissing True "doldrums-build" + let rtObj = "doldrums-build/libruntime.a" + (exitCode, _, err) <- readProcessWithExitCode "rustc" + ["runtime.rs", "--crate-type", "staticlib", "-o", rtObj, "-O"] "" + when (exitCode /= ExitSuccess) $ + error $ "Runtime compilation failed: " <> err + +cleanup :: () -> IO () +cleanup _ = removeContents "doldrums-build" + +-- remove everything except `libruntime.a` +removeContents :: FilePath -> IO () +removeContents dir = do + contents <- listDirectory dir + forM_ (map (dir ) contents) $ \path -> do + isDir <- doesDirectoryExist path + case (takeFileName path, isDir) of + ("libruntime.a", _) -> pure () + (_, True) -> removeDirectoryRecursive path + _ -> removeFile path + data TestDirective = ExpectDirective Text | IgnoreDirective @@ -95,12 +120,22 @@ mkDolTest (TestProgram name content BrokenDirective) = Just (Right _) -> expectationFailure "Expected an exception but program succeeded" Just (Left (e :: SomeException)) -> do TIO.putStrLn $ " " <> pack (show e) -mkDolTest (TestProgram name content (ExpectDirective expected)) = - it (unpack name) $ do +mkDolTest (TestProgram name content (ExpectDirective expected)) = do + it (unpack name <> " (interpreted)") $ do result <- timeout 100_000 $ execute content NoDebugInfo Interpreted case result of Nothing -> expectationFailure "Timed out after 100ms" Just output -> output `shouldBe` expected + it (unpack name <> " (compiled)") $ do + let timeoutLengthMilliseconds = 10000 + result <- timeout (timeoutLengthMilliseconds * 1000) . try $ execute content NoDebugInfo Compiled + case result of + Nothing -> + expectationFailure $ "Timed out after " <> show timeoutLengthMilliseconds <> "ms" + Just (Left (e :: SomeException)) -> do + expectationFailure $ "Got exception: " <> show e + Just (Right output) -> + T.strip output `shouldBe` T.strip expected mkDolTest (TestProgram name _ MissingDirective) = it (unpack name) $ expectationFailure $ diff --git a/test/expect/backtick-chained.dol b/test/expect/backtick-chained.dol index 86b7d55..5ab9243 100644 --- a/test/expect/backtick-chained.dol +++ b/test/expect/backtick-chained.dol @@ -2,4 +2,4 @@ add x y = x + y mul x y = x * y -main = print $ show $ 1 `add` 2 `mul` 3 +main = print $ 1 `add` 2 `mul` 3 diff --git a/test/expect/backtick-map.dol b/test/expect/backtick-map.dol index 340ca4c..c5a31bd 100644 --- a/test/expect/backtick-map.dol +++ b/test/expect/backtick-map.dol @@ -1,4 +1,4 @@ --- EXPECT Cons 2 (Cons 3 (Cons 4 Nil)) +-- EXPECT [2,3,4] addOne x = x + 1 main = print $ addOne `map` [1,2,3] diff --git a/test/expect/backtick-simple.dol b/test/expect/backtick-simple.dol index 85065de..b8e0b76 100644 --- a/test/expect/backtick-simple.dol +++ b/test/expect/backtick-simple.dol @@ -1,4 +1,4 @@ -- EXPECT 3 add x y = x + y -main = print $ show $ 1 `add` 2 +main = print $ 1 `add` 2 diff --git a/test/expect/big-number.dol b/test/expect/big-number.dol index c8fcb37..963dd6c 100644 --- a/test/expect/big-number.dol +++ b/test/expect/big-number.dol @@ -1,4 +1,4 @@ --- EXPECT 2361183241434822606848 +-- EXPECT 4611686018427387904 --- big numeric literal, 2^70 -main = print $ 1180591620717411303424 * 2 +-- big numeric literal, 2^61 +main = print $ 2305843009213693952 * 2 diff --git a/test/expect/cycle.dol b/test/expect/cycle.dol index 6c3465c..d92c270 100644 --- a/test/expect/cycle.dol +++ b/test/expect/cycle.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 2 (Cons 3 (Cons 1 (Cons 2 Nil)))) +-- EXPECT [1,2,3,1,2] main = print $ take 5 $ cycle [1, 2, 3] diff --git a/test/expect/drop-while.dol b/test/expect/drop-while.dol index 3c60cd2..4d62e92 100644 --- a/test/expect/drop-while.dol +++ b/test/expect/drop-while.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 3 (Cons 4 (Cons 1 Nil)) +-- EXPECT [3,4,1] main = print $ dropWhile (\x -> x < 3) [1, 2, 3, 4, 1] diff --git a/test/expect/enum_from_to.dol b/test/expect/enum_from_to.dol new file mode 100644 index 0000000..e6402ff --- /dev/null +++ b/test/expect/enum_from_to.dol @@ -0,0 +1,2 @@ +-- EXPECT [5,6,7] +main = print $ enumFromTo 5 7 diff --git a/test/expect/hello-world.dol b/test/expect/hello-world.dol index 5f2fcec..3dc242c 100644 --- a/test/expect/hello-world.dol +++ b/test/expect/hello-world.dol @@ -1,2 +1,2 @@ -- EXPECT Hello, world! -main = print $ "Hello, world!" +main = putStrLn $ "Hello, world!" diff --git a/test/expect/lines.dol b/test/expect/lines.dol index 665e3ab..464127c 100644 --- a/test/expect/lines.dol +++ b/test/expect/lines.dol @@ -1,3 +1,3 @@ --- EXPECT Cons hello (Cons world Nil) +-- EXPECT ["hello","world"] main = print $ lines "hello\nworld" diff --git a/test/expect/list-cons-operator.dol b/test/expect/list-cons-operator.dol index a48455f..6f97f52 100644 --- a/test/expect/list-cons-operator.dol +++ b/test/expect/list-cons-operator.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 2 (Cons 3 Nil)) +-- EXPECT [1,2,3] main = print $ 1 : 2 : 3 : Nil diff --git a/test/expect/list-empty.dol b/test/expect/list-empty.dol index 2d1ab3e..e9b0cb1 100644 --- a/test/expect/list-empty.dol +++ b/test/expect/list-empty.dol @@ -1,3 +1,3 @@ --- EXPECT Nil +-- EXPECT [] main = print $ [] diff --git a/test/expect/list-literal.dol b/test/expect/list-literal.dol index 064bb07..876cdf4 100644 --- a/test/expect/list-literal.dol +++ b/test/expect/list-literal.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 2 (Cons 3 Nil)) +-- EXPECT [1,2,3] main = print $ [1, 2, 3] diff --git a/test/expect/list-map.dol b/test/expect/list-map.dol index 55a4b16..b2d2023 100644 --- a/test/expect/list-map.dol +++ b/test/expect/list-map.dol @@ -1,4 +1,4 @@ --- EXPECT Cons 2 (Cons 3 (Cons 4 Nil)) +-- EXPECT [2,3,4] main = print $ map addOne [1, 2, 3] diff --git a/test/expect/list-range-step.dol b/test/expect/list-range-step.dol index 79971fc..17748cf 100644 --- a/test/expect/list-range-step.dol +++ b/test/expect/list-range-step.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 3 (Cons 5 (Cons 7 (Cons 9 Nil)))) +-- EXPECT [1,3,5,7,9] main = print $ [1,3..10] diff --git a/test/expect/list-range.dol b/test/expect/list-range.dol index 2eca7aa..7429b95 100644 --- a/test/expect/list-range.dol +++ b/test/expect/list-range.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 5 Nil)))) +-- EXPECT [1,2,3,4,5] main = print $ [1..5] diff --git a/test/expect/map-list.dol b/test/expect/map-list.dol index c2cb590..90786ac 100644 --- a/test/expect/map-list.dol +++ b/test/expect/map-list.dol @@ -1,4 +1,4 @@ --- EXPECT Cons 2 (Cons 3 (Cons 4 Nil)) +-- EXPECT [2,3,4] main = print $ map addOne [1, 2, 3] diff --git a/test/expect/multiple-top-level-pattern-matches.dol b/test/expect/multiple-top-level-pattern-matches.dol index 2865691..85bfb8f 100644 --- a/test/expect/multiple-top-level-pattern-matches.dol +++ b/test/expect/multiple-top-level-pattern-matches.dol @@ -4,4 +4,4 @@ f x = x f y = y -main = print $ f "hello" +main = putStrLn $ f "hello" diff --git a/test/expect/num-string-print.dol b/test/expect/num-string-print.dol new file mode 100644 index 0000000..2a85f87 --- /dev/null +++ b/test/expect/num-string-print.dol @@ -0,0 +1,5 @@ +-- EXPECT 7 is (Num, Show) and so is 8.0 + +main = putStrLn $ describeNumber 8.0 + +describeNumber x = show 7 <> " is (Num, Show) and so is " <> show x diff --git a/test/expect/print_add.dol b/test/expect/print_add.dol new file mode 100644 index 0000000..3329485 --- /dev/null +++ b/test/expect/print_add.dol @@ -0,0 +1,2 @@ +-- EXPECT 15 +main = print $ 7 + 8 diff --git a/test/expect/range_print.dol b/test/expect/range_print.dol new file mode 100644 index 0000000..2a997b6 --- /dev/null +++ b/test/expect/range_print.dol @@ -0,0 +1,2 @@ +-- EXPECT 3 +main = print $ length [5..7] diff --git a/test/expect/record-multi-accessor.dol b/test/expect/record-multi-accessor.dol index a1ff5d7..5a04c92 100644 --- a/test/expect/record-multi-accessor.dol +++ b/test/expect/record-multi-accessor.dol @@ -2,4 +2,4 @@ data Foo = Foo { bar :: Int, baz :: String } -main = print $ baz (Foo 42 "hello") +main = putStrLn $ baz (Foo 42 "hello") diff --git a/test/expect/repeat.dol b/test/expect/repeat.dol index d30a18c..c0f140c 100644 --- a/test/expect/repeat.dol +++ b/test/expect/repeat.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 7 (Cons 7 (Cons 7 Nil)) +-- EXPECT [7,7,7] main = print $ take 3 $ repeat 7 diff --git a/test/expect/replicate.dol b/test/expect/replicate.dol index 332432c..eba1ef2 100644 --- a/test/expect/replicate.dol +++ b/test/expect/replicate.dol @@ -1,3 +1,3 @@ --- EXPECT Cons ha (Cons ha (Cons ha Nil)) +-- EXPECT ["ha","ha","ha"] main = print $ replicate 3 "ha" diff --git a/test/expect/section-bound.dol b/test/expect/section-bound.dol index 0a3c6eb..d7f0df2 100644 --- a/test/expect/section-bound.dol +++ b/test/expect/section-bound.dol @@ -1,4 +1,4 @@ -- EXPECT 12 double = (2*) inc = (+1) -main = print $ show (double (inc 5)) +main = print $ double (inc 5) diff --git a/test/expect/section-left-space.dol b/test/expect/section-left-space.dol index 09ffc5d..8157b19 100644 --- a/test/expect/section-left-space.dol +++ b/test/expect/section-left-space.dol @@ -1,2 +1,2 @@ -- EXPECT 3 -main = print $ show ((1 +) 2) +main = print ((1 +) 2) diff --git a/test/expect/section-left.dol b/test/expect/section-left.dol index a545d1e..08e4d23 100644 --- a/test/expect/section-left.dol +++ b/test/expect/section-left.dol @@ -1,2 +1,2 @@ -- EXPECT 3 -main = print $ show ((1+) 2) +main = print $ (1+) 2 diff --git a/test/expect/section-minus.dol b/test/expect/section-minus.dol index 531f07a..79d0e98 100644 --- a/test/expect/section-minus.dol +++ b/test/expect/section-minus.dol @@ -1,2 +1,2 @@ -- EXPECT 4 -main = print $ show ((- 1) 5) +main = print ((- 1) 5) diff --git a/test/expect/section-negation.dol b/test/expect/section-negation.dol index 17d5439..e09ea9d 100644 --- a/test/expect/section-negation.dol +++ b/test/expect/section-negation.dol @@ -1,2 +1,2 @@ -- EXPECT -1 -main = print $ show ((-1)) +main = print $ ((-1)) diff --git a/test/expect/section-operator-parens.dol b/test/expect/section-operator-parens.dol index 0e7e6f2..36f282a 100644 --- a/test/expect/section-operator-parens.dol +++ b/test/expect/section-operator-parens.dol @@ -1,2 +1,2 @@ -- EXPECT 5 -main = print $ show ((+) 2 3) +main = print $ ((+) 2 3) diff --git a/test/expect/section-right-space.dol b/test/expect/section-right-space.dol index bcd011b..db2c02f 100644 --- a/test/expect/section-right-space.dol +++ b/test/expect/section-right-space.dol @@ -1,2 +1,2 @@ -- EXPECT 3 -main = print $ show ((+ 1) 2) +main = print $ (+ 1) 2 diff --git a/test/expect/section-right.dol b/test/expect/section-right.dol index be8ad1d..70aab4b 100644 --- a/test/expect/section-right.dol +++ b/test/expect/section-right.dol @@ -1,2 +1,2 @@ -- EXPECT 3 -main = print $ show ((+1) 2) +main = print $ ((+1) 2) diff --git a/test/expect/show.dol b/test/expect/show.dol index ad48b0c..8f27582 100644 --- a/test/expect/show.dol +++ b/test/expect/show.dol @@ -1,5 +1,5 @@ -- EXPECT x = 7 -main = print $ "x = " <> show x +main = putStrLn $ "x = " <> show x x = 7 diff --git a/test/expect/show_stg.dol b/test/expect/show_stg.dol new file mode 100644 index 0000000..42f6a35 --- /dev/null +++ b/test/expect/show_stg.dol @@ -0,0 +1,2 @@ +-- EXPECT 3 +main = print $ 1 + 2 diff --git a/test/expect/splitAt_alone.dol b/test/expect/splitAt_alone.dol new file mode 100644 index 0000000..1f784ca --- /dev/null +++ b/test/expect/splitAt_alone.dol @@ -0,0 +1,2 @@ +-- EXPECT Tuple2 [1,2] [3,4] +main = print $ splitAt 2 [1,2,3,4] diff --git a/test/expect/splitAt_range.dol b/test/expect/splitAt_range.dol new file mode 100644 index 0000000..fcc387f --- /dev/null +++ b/test/expect/splitAt_range.dol @@ -0,0 +1,3 @@ +-- EXPECT 2 +main = print $ (case splitAt 2 [1,2,3,4] of + (as, bs) -> length as) diff --git a/test/expect/splitAt_simple.dol b/test/expect/splitAt_simple.dol new file mode 100644 index 0000000..7f87e41 --- /dev/null +++ b/test/expect/splitAt_simple.dol @@ -0,0 +1,2 @@ +-- EXPECT [1,2] +main = print $ fst $ splitAt 2 [1,2,3,4] diff --git a/test/expect/string-escaping.dol b/test/expect/string-escaping.dol index bfff644..a215ea0 100644 --- a/test/expect/string-escaping.dol +++ b/test/expect/string-escaping.dol @@ -1,2 +1,2 @@ -- EXPECT Hello "world"! -main = print $ "Hello \"world\"!" +main = putStrLn $ "Hello \"world\"!" diff --git a/test/expect/sub.dol b/test/expect/sub.dol new file mode 100644 index 0000000..1030e9b --- /dev/null +++ b/test/expect/sub.dol @@ -0,0 +1,2 @@ +-- EXPECT 3 +main = print $ 5 - 2 diff --git a/test/expect/succ.dol b/test/expect/succ.dol new file mode 100644 index 0000000..3f59aa3 --- /dev/null +++ b/test/expect/succ.dol @@ -0,0 +1,2 @@ +-- EXPECT 6 +main = print $ succ 5 diff --git a/test/expect/take-while.dol b/test/expect/take-while.dol index 05acc6a..83f22d5 100644 --- a/test/expect/take-while.dol +++ b/test/expect/take-while.dol @@ -1,3 +1,3 @@ --- EXPECT Cons 1 (Cons 2 Nil) +-- EXPECT [1,2] main = print $ takeWhile (\x -> x < 3) [1, 2, 3, 4, 1] diff --git a/test/expect/text-concatenation.dol b/test/expect/text-concatenation.dol index 90ac9c0..c4919b3 100644 --- a/test/expect/text-concatenation.dol +++ b/test/expect/text-concatenation.dol @@ -1,3 +1,3 @@ -- EXPECT hello world -main = print $ "hello" <> " " <> "world" +main = putStrLn $ "hello" <> " " <> "world" diff --git a/test/expect/tour-checker.dol b/test/expect/tour-checker.dol new file mode 100644 index 0000000..f88cb5d --- /dev/null +++ b/test/expect/tour-checker.dol @@ -0,0 +1,84 @@ +-- EXPECT Hello, world!!, fib 8 = 34, fac 6 = 720, 6 * -7 = -42, 3.0 + 4.0 = 7.0, myLength (MyCons 1 (MyCons 2 MyNil)) = 2, eq 0 0 = True, 7 is (Num, Show) and so is 8.0 + +-- doldrums tour - test version +-- run with: cabal run doldrums -- tour.dol + +{- Block comments work too! + + Doldrums is a small, purely functional programming language + with an emphasis on ease of top-to-bottom understanding. + It's like a tiny Haskell. + +-} + +-- top-level type signatures with `::` +seven :: Int +seven = 7 + +-- algebraic datatypes +-- uppercase constructors with types to list arguments + +data MyList a = MyNil | MyCons a (MyList a) + +-- `case` expressions deconstruct values by pattern matching +myLength :: MyList a -> Int +myLength list = + case list of + MyNil -> 0 + MyCons x xs -> 1 + myLength xs + +-- `case` allows `_` wildcard matches +fib :: Int -> Int +fib n = + case n of + 0 -> 1 + 1 -> 1 + _ -> fib (n - 1) + fib (n - 2) + +-- guard clauses with `| = ` +-- `$` has the lowest precedence, eliminating excess parentheses +fac :: Int -> Int +fac n + | n == 0 = 1 + | otherwise = n * fac (n - 1) + +-- `let`...`in` to name variables +greeting :: String +greeting = + let + h = "Hello" + w = "world" + in h <> ", " <> w + +-- `\args -> body` is an anonymous (lambda) function +-- `f . g = \x -> f (g x)` +shout :: String -> String +shout = (\s -> s <> "!") . (\s -> s <> "!") + +-- `show` converts values to string +-- `<>` concatenates strings +describeNumber :: Double -> String +describeNumber x = show 7 <> " is (Num, Show) and so is " <> show x + +-- typeclasses and instances +class Equal a where + eq :: a -> a -> Bool + +instance Equal Int where + eq x y = x == y + +-- other operators: +-- +, -, *, /, +-- ==, /=, <, >, <=, >=, +-- &&, ||, $, . + +main :: IO () +main = putStrLn $ + shout greeting <> ", " <> + "fib 8 = " <> show (fib 8) <> ", " <> + "fac 6 = " <> show (fac 6) <> ", " <> + "6 * -7 = " <> show (6 * -7) <> ", " <> + "3.0 + 4.0 = " <> show (3.0 + 4.0) <> ", " <> + "myLength (MyCons 1 (MyCons 2 MyNil)) = " <> show (myLength (MyCons 1 (MyCons 2 MyNil))) <> ", " <> + "eq 0 0 = " <> show (eq 0 0) <> ", " <> + describeNumber 8.0 diff --git a/test/expect/unlines.dol b/test/expect/unlines.dol index c6ed044..8d96af7 100644 --- a/test/expect/unlines.dol +++ b/test/expect/unlines.dol @@ -1,3 +1,3 @@ --- EXPECT Cons hello (Cons world Nil) +-- EXPECT ["hello","world"] main = print $ words (unlines (Cons "hello" (Cons "world" Nil))) diff --git a/test/expect/unwords.dol b/test/expect/unwords.dol index e74c946..a255a93 100644 --- a/test/expect/unwords.dol +++ b/test/expect/unwords.dol @@ -1,3 +1,3 @@ -- EXPECT hello world -main = print $ unwords (Cons "hello" (Cons "world" Nil)) +main = putStrLn $ unwords (Cons "hello" (Cons "world" Nil)) diff --git a/test/expect/words.dol b/test/expect/words.dol index 51d3847..a158e2d 100644 --- a/test/expect/words.dol +++ b/test/expect/words.dol @@ -1,3 +1,3 @@ --- EXPECT Cons hello (Cons world Nil) +-- EXPECT ["hello","world"] main = print $ words "hello world" diff --git a/test/expect/zip_len.dol b/test/expect/zip_len.dol new file mode 100644 index 0000000..e4e332f --- /dev/null +++ b/test/expect/zip_len.dol @@ -0,0 +1,2 @@ +-- EXPECT 3 +main = print $ length $ zip [1,2,3] [4,5,6] diff --git a/tour.dol b/tour.dol index 1f48ecd..fd4fbed 100644 --- a/tour.dol +++ b/tour.dol @@ -56,7 +56,7 @@ shout = (\s -> s <> "!") . (\s -> s <> "!") -- `show` converts values to string -- `<>` concatenates strings describeNumber :: Double -> String -describeNumber x = show 7 <> show " is (Num, Show) and so is " <> show x +describeNumber x = show 7 <> " is (Num, Show) and so is " <> show x -- typeclasses and instances class Equal a where