~jojo/Carth

4e03f8ccaa5915e479240eed790f05b7e6d3828d — JoJo 1 year, 6 months ago e6b724e
Instead of ccc everywhere, generate fastcc wrappers around externs

Pros:

- Extern declarations can now be written in a carth
  interpretation, with currying and all, because the generated wrapper
  will be curried. No need to manually write curried wrappers!

- Fastcc is faster and can optimize tail calls *way* better than
  ccc. We now have almost guaranteed tail call elimination in most
  possible cases.

Cons:

- Carth functions can now not be called from the outside, as they
  don't conform to the C abi. Maybe we'll add a feature to generate
  "reverse-wrappers" for marked carth functions.
M carth.cabal => carth.cabal +1 -0
@@ 26,6 26,7 @@ library
      Compile
      Conf
      EnvVars
      Extern
      FreeVars
      Gen
      Infer

M foreign-core/src/lib.rs => foreign-core/src/lib.rs +64 -91
@@ 4,7 4,7 @@ mod ffi;

use libc::*;
use std::io::{self, Write};
use std::{alloc, ptr, slice, str};
use std::{alloc, slice, str};

#[no_mangle]
pub extern "C" fn install_stackoverflow_handler() {


@@ 23,30 23,6 @@ pub extern "C" fn install_stackoverflow_handler() {
    }
}

macro_rules! def_carth_closure {
    ($e:expr, $s:ident, $f:ident; $ta:ty, $tr:ty; $a:pat => $b:expr) => {
        #[export_name = $e]
        pub static $s: Closure<$ta, $tr> = Closure {
            captures: ptr::null(),
            func: $f,
        };
        pub extern "C" fn $f(_: Captures, $a: $ta) -> $tr {
            $b
        }
    };
}

pub type Captures = *const ();
pub type ClosureFunc<A, B> = extern "C" fn(Captures, A) -> B;

#[repr(C)]
pub struct Closure<A, B> {
    captures: Captures,
    func: ClosureFunc<A, B>,
}

unsafe impl<A, B> Sync for Closure<A, B> {}

#[repr(C)]
pub struct Array<A> {
    elems: *mut A,


@@ 97,21 73,17 @@ pub extern "C" fn carth_str_eq(s1: Str, s2: Str) -> bool {
    s1 == s2
}

def_carth_closure! {
    "display-inline", DISPLAY_INLINE, display_inline;
    Str, (); s => {
        let s = from_carth_str(&s);
        print!("{}", s);
        io::stdout().flush().ok();
    }
#[export_name = "display-inline"]
pub extern "C" fn display_inline(s: Str) {
    let s = from_carth_str(&s);
    print!("{}", s);
    io::stdout().flush().ok();
}

def_carth_closure! {
    "-str-append", STR_APPEND, str_append;
    Pair<Str, Str>, Str; Pair { fst, snd } => {
        let (s1, s2) = (from_carth_str(&fst), from_carth_str(&snd));
        Str::new(s1.to_string() + s2)
    }
#[export_name = "str-append"]
pub extern "C" fn str_append(s1: Str, s2: Str) -> Str {
    let (s1, s2) = (from_carth_str(&s1), from_carth_str(&s2));
    Str::new(s1.to_string() + s2)
}

fn from_carth_str<'s>(s: &'s Str) -> &'s str {


@@ 122,87 94,88 @@ fn from_carth_str<'s>(s: &'s Str) -> &'s str {
    }
}

def_carth_closure! {
    "add-int", ADD_INT, add_int;
    Pair<i64, i64>, i64; Pair { fst, snd } => fst + snd
#[export_name = "+i"]
pub extern "C" fn add_int(a: i64, b: i64) -> i64 {
    a + b
}

def_carth_closure! {
    "sub-int", SUB_INT, sub_int;
    Pair<i64, i64>, i64; Pair { fst, snd } => fst - snd
#[export_name = "-i"]
pub extern "C" fn sub_int(a: i64, b: i64) -> i64 {
    a - b
}

def_carth_closure! {
    "mul-int", MUL_INT, mul_int;
    Pair<i64, i64>, i64; Pair { fst, snd } => fst * snd
#[export_name = "*i"]
pub extern "C" fn mul_int(a: i64, b: i64) -> i64 {
    a * b
}

def_carth_closure! {
    "div-int", DIV_INT, div_int;
    Pair<i64, i64>, i64; Pair { fst, snd } => fst / snd
#[export_name = "/i"]
pub extern "C" fn div_int(a: i64, b: i64) -> i64 {
    a / b
}

def_carth_closure! {
    "rem-int", REM_INT, rem_int;
    Pair<i64, i64>, i64; Pair { fst, snd } => fst % snd
#[export_name = "remi"]
pub extern "C" fn rem_int(a: i64, b: i64) -> i64 {
    a % b
}

def_carth_closure! {
    "gt-int", GT_INT, gt_int;
    Pair<i64, i64>, bool; Pair { fst, snd } => fst > snd
#[export_name = ">i"]
pub extern "C" fn gt_int(a: i64, b: i64) -> bool {
    a > b
}

def_carth_closure! {
    "eq-int", EQ_INT, eq_int;
    Pair<i64, i64>, bool; Pair { fst, snd } => fst == snd
#[export_name = "=i"]
pub extern "C" fn eq_int(a: i64, b: i64) -> bool {
    a == b
}

def_carth_closure! {
    "show-int", SHOW_INT, show_int;
    i64, Str; n =>
        Str::new(n.to_string())
#[export_name = "show-int"]
pub extern "C" fn show_int(n: i64) -> Str {
    Str::new(n.to_string())
}

def_carth_closure! {
    "add-f64", ADD_F64, add_f64;
    Pair<f64, f64>, f64; Pair { fst, snd } => fst + snd
#[export_name = "+f"]
pub extern "C" fn add_f64(a: f64, b: f64) -> f64 {
    a + b
}

def_carth_closure! {
    "sub-f64", SUB_F64, sub_f64;
    Pair<f64, f64>, f64; Pair { fst, snd } => fst - snd
#[export_name = "-f"]
pub extern "C" fn sub_f64(a: f64, b: f64) -> f64 {
    a - b
}

def_carth_closure! {
    "mul-f64", MUL_F64, mul_f64;
    Pair<f64, f64>, f64; Pair { fst, snd } => fst * snd
#[export_name = "*f"]
pub extern "C" fn mul_f64(a: f64, b: f64) -> f64 {
    a * b
}

def_carth_closure! {
    "div-f64", DIV_F64, div_f64;
    Pair<f64, f64>, f64; Pair { fst, snd } => fst / snd
#[export_name = "/f"]
pub extern "C" fn div_f64(a: f64, b: f64) -> f64 {
    a / b
}

def_carth_closure! {
    "gt-f64", GT_F64, gt_f64;
    Pair<f64, f64>, bool; Pair { fst, snd } => fst > snd
#[export_name = "remf"]
pub extern "C" fn rem_f64(a: f64, b: f64) -> f64 {
    a % b
}

def_carth_closure! {
    "eq-f64", EQ_F64, eq_f64;
    Pair<f64, f64>, bool; Pair { fst, snd } => fst == snd
#[export_name = ">f"]
pub extern "C" fn gt_f64(a: f64, b: f64) -> bool {
    a > b
}

def_carth_closure! {
    "show-f64", SHOW_F64, show_f64;
    f64, Str; n =>
        Str::new(n.to_string())
#[export_name = "=f"]
pub extern "C" fn eq_f64(a: f64, b: f64) -> bool {
    a == b
}

def_carth_closure! {
    "-panic", PANIC, panic;
    Str, (); s => {
        eprintln!("*** Panic: {}", from_carth_str(&s));
        std::process::abort()
    }
#[export_name = "show-f64"]
pub extern "C" fn show_f64(n: f64) -> Str {
    Str::new(n.to_string())
}

#[export_name = "-panic"]
pub extern "C" fn panic(s: Str) {
    eprintln!("*** Panic: {}", from_carth_str(&s));
    std::process::abort()
}

M src/Codegen.hs => src/Codegen.hs +19 -46
@@ 7,7 7,6 @@ import LLVM.AST hiding (args)
import LLVM.AST.Typed
import LLVM.AST.Type hiding (ptr)
import LLVM.AST.DataLayout
import LLVM.AST.ParameterAttribute
import qualified LLSubprog
import qualified LLCompunit
import qualified LLVM.AST.Operand as LLOp


@@ 36,19 35,20 @@ import qualified Monomorphic
import Monomorphic hiding (Type, Const)
import Selections
import Gen
import Extern


codegen :: DataLayout -> FilePath -> Program -> Module
codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
    let externs' = map (\(x, t, _) -> (x, t)) externs
        (tdefs', externs'', globDefs) = runGen' $ do
    let
        (tdefs', externs', globDefs) = runGen' $ do
            (enums, tdefs'') <- defineDataTypes tdefs
            augment enumTypes enums
                $ augment dataTypes tdefs''
                $ withExternSigs externs'
                $ withExternSigs externs
                $ withGlobDefSigs (map (second unpos) defs)
                $ do
                    es <- genExterns externs'
                    es <- genExterns externs
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs))
                    pure (tdefs'', es, ds)
    in


@@ 62,21 62,12 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
                    (\(n, tmax) -> TypeDefinition n (Just (typeStruct tmax)))
                    (Map.toList tdefs')
                , genBuiltins
                , externs''
                , externs'
                , globDefs
                , globMetadataDefs
                ]
            }
  where
    withExternSigs es ga = do
        es' <- forM es $ \(name, t) -> do
            t' <- genType' t
            pure
                ( TypedVar name t
                , ConstantOperand
                    $ LLConst.GlobalReference (LLType.ptr t') (mkName name)
                )
        augment env (Map.fromList es') ga
    withGlobDefSigs sigs ga = do
        sigs' <- forM sigs $ \(v@(TypedVar x t), (us, _)) -> do
            t' <- genType' t


@@ 167,13 158,6 @@ defineDataTypes tds = do
                    else pure (n, snd (maximum sizedTs))
    pure (enums', datas'')

genExterns :: [(String, Monomorphic.Type)] -> Gen' [Definition]
genExterns = mapM (uncurry genExtern)

genExtern :: String -> Monomorphic.Type -> Gen' Definition
genExtern name t = genType' t
    <&> \t' -> GlobalDefinition $ simpleGlobVar' (mkName name) t' Nothing

genMain :: Gen' Definition
genMain = do
    assign currentBlockLabel (mkName "entry")


@@ 181,7 165,7 @@ genMain = do
    Out basicBlocks _ _ _ <- execWriterT $ do
        emitDo' (callExtern "install_stackoverflow_handler" [])
        f <- lookupVar (TypedVar "main" mainType)
        _ <- app f (VLocal litUnit) typeUnit
        _ <- app f (VLocal litUnit)
        commitFinalFuncBlock (ret (litI32 0))
    pure (GlobalDefinition (simpleFunc (mkName "main") [] i32 basicBlocks []))



@@ 215,7 199,7 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
    case expr of
        Lit c -> genConst c
        Var (TypedVar x t) -> lookupVar (TypedVar x t)
        App f e rt -> genApp f e rt
        App f e _ -> genApp f e
        If p c a -> genIf p c a
        Fun p b -> assign lambdaParentFunc parent *> genExprLambda p b
        Let ds b -> genLet ds b


@@ 245,41 229,30 @@ genStrLit s = do
        (LLConst.GlobalReference (LLType.ptr typeStr) var)

-- | Beta-reduction and closure application
genApp :: Expr -> Expr -> Monomorphic.Type -> Gen Val
genApp fe' ae' rt' = genApp' (fe', [(ae', rt')])
genApp :: Expr -> Expr -> Gen Val
genApp fe' ae' = genApp' (fe', [ae'])
  where
    -- TODO: Could/should the beta-reduction maybe happen in an earlier stage,
    --       like when desugaring?
    genApp' = \case
        (Expr _ (Fun p (b, _)), (ae, _) : aes) -> do
        (Expr _ (Fun p (b, _)), ae : aes) -> do
            a <- genExpr ae
            withVal p a (genApp' (b, aes))
        (Expr _ (App fe ae rt), aes) -> genApp' (fe, (ae, rt) : aes)
        (Expr _ (App fe ae _), aes) -> genApp' (fe, ae : aes)
        (fe, []) -> genExpr fe
        (fe, aes) -> do
            closure <- genExpr fe
            as <- mapM
                (\(ae, rt) -> liftA2 (,) (genExpr ae) (genType rt))
                aes
            foldlM (\f (a, rt) -> app f a rt) closure as
            as <- mapM genExpr aes
            foldlM (\f a -> app f a) closure as

app :: Val -> Val -> Type -> Gen Val
app closure a rt = do
app :: Val -> Val -> Gen Val
app closure a = do
    closure' <- getLocal closure
    captures <- emitReg "captures" =<< extractvalue closure' [0]
    f <- emitReg "function" =<< extractvalue closure' [1]
    passArgByRef <- passByRef (typeOf a)
    (a', aattrs) <- if passArgByRef
        then fmap (, [ByVal]) (getVar a)
        else fmap (, []) (getLocal a)
    let args = [(captures, []), (a', aattrs)]
    returnByRef <- passByRef rt
    if returnByRef
        then do
            out <- emitReg "out" (alloca rt)
            emitDo $ callVoid f ((out, [SRet]) : args)
            pure (VVar out)
        else fmap VLocal (emitAnonReg (call f args))
    a' <- getLocal a
    let args = [(captures, []), (a', [])]
    fmap VLocal (emitAnonReg (call f args))
  where
    call f as =
        WithRetType (callVoid f as) (getFunRet (getPointee (typeOf f)))

M src/Compile.hs => src/Compile.hs +1 -0
@@ 86,6 86,7 @@ compileModule cfg tm mod = do
        , "-lsigsegv"
        , "-ldl"
        , "-lpthread"
        , "-lm"
        ]

foreign import ccall "dynamic"

A src/Extern.hs => src/Extern.hs +177 -0
@@ 0,0 1,177 @@
{-# LANGUAGE OverloadedStrings, LambdaCase, TupleSections, FlexibleContexts #-}

-- | Codegeneration related to external C function declarations
--
--   `extern` forms are translated pretty literally to extern declarations,
--   taking the C ABI into account when deciding whether to pass a ref on the
--   stack or in registers, etc. Further, ad wrapper-closure is generated around
--   the function, which translates the calling convention from C to whatever we
--   use internally (e.g. tailcc or fastcc), adds a dummy `captures` parameter
--   to make it compatible with all other function signatures, and finally it
--   adds currying.
--
--   One might think that simply declaring all function definitions and function
--   calls as being of the same "ccc" LLVM calling convention would allow us to
--   pass arguments and return results as we please, and everything will be
--   compatible? I sure did, however, that is not the case. To be compatible
--   with C FFIs, we also have to actually conform to the C calling convention,
--   which contains a bunch of details about how more complex types should be
--   passed and returned. Currently, we pass and return simple types by value,
--   and complex types by reference (param by ref, return via sret param).
--
--   See the definition of `passByRef` for up-to-date details about which types
--   are passed how.
module Extern (withExternSigs, genExterns, genBuiltins, callExtern) where

import LLVM.AST
import LLVM.AST.ParameterAttribute
import qualified LLVM.AST.Constant as LLConst
import Control.Monad.Writer
import qualified Data.Map as Map
import Lens.Micro.Platform (view, to)
import LLVM.AST.Typed
import qualified LLVM.AST.Type as LLType
import Data.Functor
import Data.Bifunctor

import Misc
import SrcPos
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import Gen


withExternSigs :: [(String, M.Type, SrcPos)] -> Gen' a -> Gen' a
withExternSigs es ga = do
    es' <- forM es $ \(name, t, _) -> do
        t' <- genType' t
        pure
            ( TypedVar name t
            , ConstantOperand $ LLConst.GlobalReference
                (LLType.ptr t')
                (mkName ("_wrapper_" ++ name))
            )
    augment env (Map.fromList es') ga

genExterns :: [(String, M.Type, SrcPos)] -> Gen' [Definition]
genExterns = fmap join . mapM genExtern

genExtern :: (String, M.Type, SrcPos) -> Gen' [Definition]
genExtern (name, t, pos) = do
    let (pts, rt) = uncurryType t
    when (null pts) $ ice "genExtern of non-function"
    let anon = mkName ""
    pts' <- mapM genType' pts
    ps <- forM pts' $ \pt' -> passByRef' pt' <&> \case
        True -> Parameter (LLType.ptr pt') anon [ByVal]
        False -> Parameter pt' anon []
    rt' <- genType' rt
    (rt'', ps') <- passByRef' rt' <&> \case
        True -> (LLType.void, Parameter (LLType.ptr rt') anon [SRet] : ps)
        False -> (rt', ps)
    let externDef = GlobalDefinition (simpleFunc (mkName name) ps' rt'' [] [])
    wrapperDefs <- genWrapper pos name rt' pts
    pure (externDef : wrapperDefs)

genWrapper :: SrcPos -> String -> Type -> [M.Type] -> Gen' [Definition]
genWrapper pos externName rt paramTs =
    case (zipWith (TypedVar . ("x" ++) . show) [1 :: Word ..] paramTs) of
        [] -> ice "genWrapper of empty param list"
        (firstParam : restParams) -> do
            let genCallExtern :: [TypedVar] -> Gen Val
                genCallExtern vars = do
                    ts <- mapM (\(TypedVar _ t) -> genType t) vars
                    vars' <- mapM lookupVar vars
                    as <- forM (zip vars' ts) $ \(v, t) -> passByRef t >>= \case
                        True -> fmap (, [ByVal]) (getVar v)
                        False -> fmap (, []) (getLocal v)
                    let ats = map (typeOf . fst) as
                    let fname = mkName externName
                    passByRef rt >>= \case
                        True -> do
                            out <- emitReg "out" (alloca rt)
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType
                                        LLType.void
                                        (typeOf out : ats)
                                        False
                                    )
                                    fname
                            emitDo $ callVoid f ((out, [SRet]) : as)
                            pure (VVar out)
                        False ->
                            let
                                f = ConstantOperand $ LLConst.GlobalReference
                                    (LLType.ptr $ FunctionType rt ats False)
                                    fname
                                call = WithRetType
                                    (callVoid f as)
                                    (getFunRet (getPointee (typeOf f)))
                            in fmap VLocal (emitAnonReg call)
            let
                genWrapper' fvs = \case
                    [] -> genCallExtern fvs
                    (p : ps) -> do
                        pts <- mapM (\(TypedVar _ t) -> genType t) ps
                        let bt = foldr closureType rt pts
                        genLambda fvs p (genWrapper' (fvs ++ [p]) ps, bt)
            let fname = mkName ("_wrapper_f_" ++ externName)
            (f, gs) <- locallySet srcPos (Just pos) $
                genFunDef
                    ( fname
                    , []
                    , pos
                    , firstParam
                    , genWrapper' [firstParam] restParams
                    )
            let fref = LLConst.GlobalReference (LLType.ptr (typeOf f)) fname
            let captures = LLConst.Null (LLType.ptr typeUnit)
            let closure = litStruct [captures, fref]
            let closureDef = simpleGlobVar
                    (mkName ("_wrapper_" ++ externName))
                    (typeOf closure)
                    closure
            pure (GlobalDefinition closureDef : GlobalDefinition f : gs)

uncurryType :: M.Type -> ([M.Type], M.Type)
uncurryType = \case
    M.TFun a b -> first (a :) (uncurryType b)
    t -> ([], t)

passByRef :: Type -> Gen Bool
passByRef = lift . passByRef'

-- NOTE: This post is helpful:
--       https://stackoverflow.com/questions/42411819/c-on-x86-64-when-are-structs-classes-passed-and-returned-in-registers
--       Also, official docs:
--       https://software.intel.com/sites/default/files/article/402129/mpx-linux64-abi.pdf
--       particularly section 3.2.3 Parameter Passing (p18).
passByRef' :: Type -> Gen' Bool
passByRef' = \case
    NamedTypeReference x -> view (dataTypes . to (Map.lookup x)) >>= \case
        Just ts -> passByRef' (typeStruct ts)
        Nothing ->
            ice $ "passByRef': No dataType for NamedTypeReference " ++ show x
    -- Simple scalar types. They go in registers.
    VoidType -> pure False
    IntegerType _ -> pure False
    PointerType _ _ -> pure False
    FloatingPointType _ -> pure False
    -- Functions are not POD (Plain Ol' Data), so they are passed on the stack.
    FunctionType _ _ _ -> pure True
    -- TODO: Investigate how exactly SIMD vectors are to be passed when/if we
    --       ever add support for that in the rest of the compiler.
    VectorType _ _ -> pure True
    -- Aggregate types can either be passed on stack or in regs, depending on
    -- what they contain.
    t@(StructureType _ us) -> do
        size <- sizeof t
        if size > 16 then pure True else fmap or (mapM passByRef' us)
    ArrayType _ u -> do
        size <- sizeof u
        if size > 16 then pure True else passByRef' u
    -- N/A
    MetadataType -> ice "passByRef of MetadataType"
    LabelType -> ice "passByRef of LabelType"
    TokenType -> ice "passByRef of TokenType"

M src/Gen.hs => src/Gen.hs +20 -90
@@ 10,6 10,7 @@ module Gen where
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Reader
import Control.Applicative
import qualified Codec.Binary.UTF8.String as UTF8.String
import Data.Map (Map)
import Data.Word


@@ 124,32 125,14 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
            (capturesParam, captureLocals) <- genExtractCaptures
            pt' <- genType pt
            px' <- newName px
            passParamByRef <- passByRef pt'
            let (withParam, pt'', pattrs) = if passParamByRef
                    then (withVar, LLType.ptr pt', [ByVal])
                    else (withLocal, pt', [])
            let pRef = LocalReference pt'' px'
            result <- getLocal =<< withParam
                ptv
                pRef
                (withLocals captureLocals genBody)
            let pRef = LocalReference pt' px'
            result <- getLocal
                =<< withLocal ptv pRef (withLocals captureLocals genBody)
            let rt' = typeOf result
            let
                fParams' =
                    [ uncurry Parameter capturesParam []
                    , Parameter pt'' px' pattrs
                    ]
            -- Return result according to calling convention
            returnResultByRef <- passByRef rt'
            if returnResultByRef
                then do
                    let out = (LLType.ptr rt', mkName "out")
                    emitDo (store result (uncurry LocalReference out))
                    commitFinalFuncBlock retVoid
                    pure (LLType.void, uncurry Parameter out [SRet] : fParams')
                else do
                    commitFinalFuncBlock (ret result)
                    pure (rt', fParams')
            let fParams' =
                    [uncurry Parameter capturesParam [], Parameter pt' px' []]
            commitFinalFuncBlock (ret result)
            pure (rt', fParams')
    (funScopeMdId, funScopeMdDef) <- defineFunScopeMetadata
    ss <- mapM globStrVar globStrings
    ls <- fmap


@@ 288,7 271,7 @@ genLambda' p@(TypedVar _ pt) (b, bt) captures fvXs = do
        Just s ->
            fmap (mkName . ((s ++ "_func_") ++) . show) (outerLambdaN <<+= 1)
        Nothing -> newName "func"
    ft <- genType pt >>= \pt' -> lift (genClosureFunType pt' bt)
    ft <- genType pt <&> \pt' -> closureFunType pt' bt
    let
        f = VLocal $ ConstantOperand $ LLConst.GlobalReference
            (LLType.ptr ft)


@@ 502,7 485,7 @@ genType' = \case
        Monomorphic.TInt32 -> i32
        Monomorphic.TInt -> i64
        Monomorphic.TF64 -> double
    Monomorphic.TFun a r -> genClosureType a r
    Monomorphic.TFun a r -> liftA2 closureType (genType' a) (genType' r)
    Monomorphic.TBox t -> fmap LLType.ptr (genType' t)
    Monomorphic.TConst tc -> lookupEnum tc <&> \case
        Just 0 -> typeUnit


@@ 512,39 495,23 @@ genType' = \case
genDatatypeRef :: Monomorphic.TConst -> Type
genDatatypeRef = NamedTypeReference . mkName . mangleTConst

    -- | A `Fun` is a closure, and follows a certain calling convention
-- | A `Fun` is a closure, and follows a certain calling convention
--
--   A closure is represented as a pair where the first element is the pointer
--   to the structure of captures, and the second element is a pointer to the
--   actual function, which takes as first parameter the captures-pointer, and
--   as second parameter the argument.
--
--   An argument of a structure-type is passed by reference, to be compatible
--   with the C calling convention.
genClosureType :: Monomorphic.Type -> Monomorphic.Type -> Gen' Type
genClosureType a r = do
    a' <- genType' a
    r' <- genType' r
    c <- genClosureFunType a' r'
    pure (typeStruct [LLType.ptr typeUnit, LLType.ptr c])
closureType :: Type -> Type -> Type
closureType a r =
    typeStruct [LLType.ptr typeUnit, LLType.ptr (closureFunType a r)]

-- The type of the function itself within the closure
genClosureFunType :: Type -> Type -> Gen' Type
genClosureFunType a r = do
    passArgByRef <- passByRef' a
    let a' = if passArgByRef then LLType.ptr a else a
    returnResultByRef <- passByRef' r
    pure $ if returnResultByRef
        then FunctionType
            { resultType = LLType.void
            , argumentTypes = [LLType.ptr r, LLType.ptr typeUnit, a']
            , isVarArg = False
            }
        else FunctionType
            { resultType = r
            , argumentTypes = [LLType.ptr typeUnit, a']
            , isVarArg = False
            }
closureFunType :: Type -> Type -> Type
closureFunType a r = FunctionType
    { resultType = r
    , argumentTypes = [LLType.ptr typeUnit, a]
    , isVarArg = False
    }

genCapturesType :: [Monomorphic.TypedVar] -> Gen Type
genCapturesType =


@@ 564,43 531,6 @@ tagBitWidth span'
    | span' <= 2 ^ (64 :: Integer) = Just 64
    | otherwise = ice $ "tagBitWidth: span' = " ++ show span'

passByRef :: Type -> Gen Bool
passByRef = lift . passByRef'

-- NOTE: This post is helpful:
--       https://stackoverflow.com/questions/42411819/c-on-x86-64-when-are-structs-classes-passed-and-returned-in-registers
--       Also, official docs:
--       https://software.intel.com/sites/default/files/article/402129/mpx-linux64-abi.pdf
--       particularly section 3.2.3 Parameter Passing (p18).
passByRef' :: Type -> Gen' Bool
passByRef' = \case
    NamedTypeReference x -> view (dataTypes . to (Map.lookup x)) >>= \case
        Just ts -> passByRef' (typeStruct ts)
        Nothing ->
            ice $ "passByRef': No dataType for NamedTypeReference " ++ show x
    -- Simple scalar types. They go in registers.
    VoidType -> pure False
    IntegerType _ -> pure False
    PointerType _ _ -> pure False
    FloatingPointType _ -> pure False
    -- Functions are not POD (Plain Ol' Data), so they are passed on the stack.
    FunctionType _ _ _ -> pure True
    -- TODO: Investigate how exactly SIMD vectors are to be passed when/if we
    --       ever add support for that in the rest of the compiler.
    VectorType _ _ -> pure True
    -- Aggregate types can either be passed on stack or in regs, depending on
    -- what they contain.
    t@(StructureType _ us) -> do
        size <- sizeof t
        if size > 16 then pure True else fmap or (mapM passByRef' us)
    ArrayType _ u -> do
        size <- sizeof u
        if size > 16 then pure True else passByRef' u
    -- N/A
    MetadataType -> ice "passByRef of MetadataType"
    LabelType -> ice "passByRef of LabelType"
    TokenType -> ice "passByRef of TokenType"

-- TODO: Handle different data layouts. Check out LLVMs DataLayout class and
--       impl of `getTypeAllocSize`.
--       https://llvm.org/doxygen/classllvm_1_1DataLayout.html

M std/iter.carth => std/iter.carth +4 -4
@@ 8,15 8,15 @@
(define (next (Iter it)) (it Unit))
(define (next! it) (unwrap! (next it)))

(define (xrange a b) (take (- b a)       (range-from a)))
(define (range  a b) (take (inc (- b a)) (range-from a)))
(define (xrange a b) (take (-i b a)       (range-from a)))
(define (range  a b) (take (inc (-i b a)) (range-from a)))

(define (range-from a)
  (Iter (fun (_) (Some (Pair a (range-from (inc a)))))))

(define (take n xs)
  (Iter (if (> n 0)
            (fun (_) (map-maybe (map-snd (take (- n 1))) (next xs)))
  (Iter (if (>i n 0)
            (fun (_) (map-maybe (map-snd (take (-i n 1))) (next xs)))
          (fun (_) None))))

(define (skip-while pred xs)

M std/math.carth => std/math.carth +28 -74
@@ 1,78 1,32 @@
;;; Math

(define (inc n) (+ n 1))
(define (dec n) (- n 1))

(extern rem-int (Fun (Pair Int Int) Int))
(define (rem a b)
  (rem-int (Pair a b)))

(extern add-int (Fun (Pair Int Int) Int))
(define (+ a b)
  (add-int (Pair a b)))

(extern sub-int (Fun (Pair Int Int) Int))
(define (- a b)
  (sub-int (Pair a b)))

(extern mul-int (Fun (Pair Int Int) Int))
(define (* a b)
  (mul-int (Pair a b)))

(extern div-int (Fun (Pair Int Int) Int))
(define (/ a b)
  (div-int (Pair a b)))

(extern eq-int (Fun (Pair Int Int) Bool))
(define (= a b)
  (eq-int (Pair a b)))

(extern gt-int (Fun (Pair Int Int) Bool))
(define (> a b)
  (gt-int (Pair a b)))

(define (>= a b)
  (or (> a b) (= a b)))


(extern rem-f64 (Fun (Pair F64 F64) F64))
(define (remf a b)
  (rem-f64 (Pair a b)))

(extern add-f64 (Fun (Pair F64 F64) F64))
(define (+f a b)
  (add-f64 (Pair a b)))

(extern sub-f64 (Fun (Pair F64 F64) F64))
(define (-f a b)
  (sub-f64 (Pair a b)))

(extern mul-f64 (Fun (Pair F64 F64) F64))
(define (*f a b)
  (mul-f64 (Pair a b)))

(extern div-f64 (Fun (Pair F64 F64) F64))
(define (/f a b)
  (div-f64 (Pair a b)))

(extern eq-f64 (Fun (Pair F64 F64) Bool))
(define (=f a b)
  (eq-f64 (Pair a b)))

(extern gt-f64 (Fun (Pair F64 F64) Bool))
(define (>f a b)
  (gt-f64 (Pair a b)))

(define (>=f a b)
  (or (>f a b) (=f a b)))

(define (and p q)
  (if p q False))
(define (or p q)
  (if p True q))
(define (inc n) (+i n 1))
(define (dec n) (-i n 1))

(extern +i (Fun Int Int Int))
(extern -i (Fun Int Int Int))
(extern *i (Fun Int Int Int))
(extern /i (Fun Int Int Int))
(extern =i (Fun Int Int Bool))
(extern >i (Fun Int Int Bool))
(define (>=i a b) (or (>i a b) (=i a b)))
(define (<i  a b) (not (>=i a b)))
(define (<=i a b) (not (>i a b)))
(extern remi (Fun Int Int Int))

(extern +f (Fun F64 F64 F64))
(extern -f (Fun F64 F64 F64))
(extern *f (Fun F64 F64 F64))
(extern /f (Fun F64 F64 F64))
(extern =f (Fun F64 F64 Bool))
(extern >f (Fun F64 F64 Bool))
(define (>=f a b) (or (>f a b) (=f a b)))
(define (<f  a b) (not (>=f a b)))
(define (<=f a b) (not (>f a b)))
(extern remf (Fun F64 F64 F64))

(define (and p q) (if p q    False))
(define (or  p q) (if p True q))

(define not (fmatch (case True False)
                    (case False True)))

(define (divisible? n m)
  (= (rem n m) 0))
(define (divisible? n m) (=i (remi n m) 0))

M std/std.carth => std/std.carth +1 -3
@@ 23,9 23,7 @@
(extern show-int (Fun Int Str))
(extern show-f64 (Fun F64 Str))

(extern -str-append (Fun (Pair Str Str) Str))
(define (str-append s1 s2)
  (-str-append (Pair s1 s2)))
(extern str-append (Fun Str Str Str))

;;; IO