~cypheon/rapid

1e8e3556b63fa1c4c77d31a96e4711bf25af7687 — Johann Rudloff 2 years ago 0c8c299 + 61aec3c new-alloc
Merge branch 'main' into new-alloc
M CMakeLists.txt => CMakeLists.txt +2 -0
@@ 14,6 14,7 @@ add_idris_package(rapid-lite rapid-lite.ipkg
  src/Compiler/LLVM/Instruction.idr
  src/Compiler/LLVM/IR.idr
  src/Compiler/LLVM/Rapid/Builtin.idr
  src/Compiler/LLVM/Rapid/Closure.idr
  src/Compiler/LLVM/Rapid/Foreign.idr
  src/Compiler/LLVM/Rapid/Integer.idr
  src/Compiler/LLVM/Rapid/Object.idr


@@ 38,6 39,7 @@ add_idris_package(rapidc rapidc.ipkg
  src/Compiler/LLVM/Instruction.idr
  src/Compiler/LLVM/IR.idr
  src/Compiler/LLVM/Rapid/Builtin.idr
  src/Compiler/LLVM/Rapid/Closure.idr
  src/Compiler/LLVM/Rapid/Foreign.idr
  src/Compiler/LLVM/Rapid/Integer.idr
  src/Compiler/LLVM/Rapid/Object.idr

D scratch.md => scratch.md +0 -60
@@ 1,60 0,0 @@
# HHVM Calling Conv (x86_64)

Call:
    CCIfType<[i64], CCAssignToReg<[
    RBX, R12, RBP, R15, RDI, RSI, RDX, RCX, R8, R9, RAX, R10, R11, R13, R14
    ]>>

Return:
    CCIfType<[i64], CCAssignToReg<[
    RBX, RBP, RDI, RSI, RDX, RCX, R8, R9, RAX, R10, R11, R13, R14, R15
    ]>>

OLD:
    RBX -> Heap
    RBP -> Base
    RDI -> HeapLim

NEW:
    RBX -> Heap
    R12 -> Base (callee saved)
    RBP -> HeapLim
    R15, RDI, RSI... -> arg0, arg1, arg2...


    RBX, R12, RBP, R15, RDI, RSI, RDX, RCX, R8, R9, RAX, R10, R11, R13, R14
    |         |         |    |    |    |    |   |   |    |    |    |    |
    V         V         V    V    V    V    V   V   V    V    V    V    V
    RBX,      RBP,      RDI, RSI, RDX, RCX, R8, R9, RAX, R10, R11, R13, R14, R15

Object Header:

Constructors:
  MSB           LSB
  4 Bytes | 4 Bytes
  ObjTyp  |     Tag

  ObjTyp : 0 == Constructor without Args

Opaque Data:
  MSB           LSB
  4 Bytes | 4 Bytes
  ObjTyp  |    Size (may not contain GC pointers)

  ObjTyp : 1 == Int64 (8 Bytes no gc) TODO: "tag" field is size -> 8 bytes
  ObjTyp : 2 == String (Length in bytes)

  ObjTyp : 3 == Closure
    Closure layout:
    HEADER (4bytes type `<<` 32, 2bytes argsMissing `<<` 16, 2bytes argsStored)
    FUNCPTR (8bytes, no gc)
    ARGS [repeat argsStored] * 8 bytes -> ObjPtr (yes gc)

  ObjTyp : 4 == Char
    HEADER: (MSB 4 Bytes ObjType, LSB 4 Bytes Unicode Codepoint)

  ObjTyp : 5 == IORef
  ObjTyp : 6 == IOBuffer
    HEADER (4 bytes type `<<` 32, 4 bytes size (number of bytes))
  ObjTyp : 7 == C opaque data
    HEADER (4 bytes type `<<` 32, 4 bytes size (number of bytes))

M src/Compiler/GenLLVMIR.idr => src/Compiler/GenLLVMIR.idr +42 -32
@@ 11,6 11,7 @@ import Compiler.CompileExpr
import Compiler.VMCode
import Compiler.LLVM.IR
import Compiler.LLVM.Instruction
import Compiler.LLVM.Rapid.Closure
import Compiler.LLVM.Rapid.Integer
import Compiler.LLVM.Rapid.Builtin
import Compiler.LLVM.Rapid.Foreign


@@ 28,13 29,6 @@ import Rapid.Common
-- we provide our own in Data.Utils
%hide Core.Name.Namespace.showSep

CLOSURE_MAX_ARGS : Int
CLOSURE_MAX_ARGS = 1024

-- A "fat" closure is always invoked via its "closure entry" function
FAT_CLOSURE_LIMIT : Int
FAT_CLOSURE_LIMIT = 8

ToIR Reg where
  toIR (Loc i) = "%v" ++ show i
  toIR RVal = "%rval"


@@ 149,6 143,17 @@ prepareArg RVal = do
  addError "cannot use rval as call arg"
  pure nullPtr

prepareArgWithConstInfo : Reg -> Codegen (Maybe String, IRValue IRObjPtr)
prepareArgWithConstInfo Discard = do
  pure (Just "(ERROR)", nullPtr)
prepareArgWithConstInfo r@(Loc i) = do
  isConst <- isValueConst i
  val <- load (reg2val r)
  pure (isConst, val)
prepareArgWithConstInfo RVal = do
  addError "cannot use rval as call arg"
  pure (Just "(ERROR)", nullPtr)

data ConstCaseType = IntLikeCase Constant | BigIntCase | StringCase | CharCase

total


@@ 897,8 902,18 @@ getInstIR (OP r (GTE ty) [r1, r2]) = intCompare' (intKind ty) "uge" "sge" r r1 r
getInstIR (OP r (GT  ty) [r1, r2]) = intCompare' (intKind ty) "ugt" "sgt" r r1 r2

getInstIR (MKCON r (Left tag) args) = do
  obj <- mkCon tag !(traverse prepareArg args)
  argsC <- traverse prepareArgWithConstInfo args
  -- check if all arguments are constants
  let allConst = traverse fst argsC
  obj <- case allConst of
              Just constArgs => do constCon <- mkConstCon tag constArgs
                                   case r of
                                        Loc i => do trackValueConst i (toIR constCon)
                                                    pure constCon
                                        _ => pure constCon
              Nothing => mkCon tag (map snd argsC)
  store obj (reg2val r)

getInstIR {conNames} (MKCON r (Right n) args) = do
  case lookup n conNames of
       Just nameId => do


@@ 908,29 923,14 @@ getInstIR {conNames} (MKCON r (Right n) args) = do
       Nothing => addError $ "MKCON name not found: " ++ show n

getInstIR (MKCLOSURE r n missingN args) = do
  let missing = cast {to=Int} missingN
  let len = cast {to=Int} $ length args
  let totalArgsExpected = missing + len
  if totalArgsExpected > (cast CLOSURE_MAX_ARGS) then addError $ "ERROR : too many closure arguments: " ++ show totalArgsExpected ++ " > " ++ show CLOSURE_MAX_ARGS else do
  let header = constHeader OBJECT_TYPE_ID_CLOSURE (cast ((missing * 0x10000) + len))
  newObj <- dynamicAllocate (Const I64 $ cast (8 + 8 * len))
  putObjectHeader newObj header
  funcPtr <- (if (totalArgsExpected <= (cast FAT_CLOSURE_LIMIT))
             then
               assignSSA $ "bitcast %FuncPtrArgs" ++ show totalArgsExpected ++ " @" ++ (safeName n) ++ " to %FuncPtr"
             else do
               assignSSA $ "bitcast %FuncPtrClosureEntry @" ++ (safeName n) ++ "$$closureEntry to %FuncPtr"
               )

  putObjectSlot newObj (Const I64 0) (SSA FuncPtr funcPtr)
  for_ (enumerate args) (\iv => do
      let (i, arg) = iv
      argObj <- load {t=IRObjPtr} (reg2val arg)
      putObjectSlot newObj (Const I64 $ cast $ i+1) argObj
      pure ()
                              )
  argsV <- traverse prepareArg args
  newObj <- mkClosure n missingN argsV
  store newObj (reg2val r)

  case r of
       Loc i => when (length args == 0) (trackValueConst i (toIR newObj))
       _ => pure ()

getInstIR (APPLY r fun arg) = do
  hp <- ((++) "%RuntimePtr ") <$> assignSSA "load %RuntimePtr, %RuntimePtr* %HpVar"
  hpLim <- ((++) "%RuntimePtr ") <$> assignSSA "load %RuntimePtr, %RuntimePtr* %HpLimVar"


@@ 997,12 997,13 @@ getInstIR (MKCONSTANT r WorldVal) = do
  store obj (reg2val r)
getInstIR (MKCONSTANT r (Str s)) = store !(mkStr s) (reg2val r)

getInstIR (CONSTCASE r alts def) = case findConstCaseType alts of
getInstIR (CONSTCASE r alts def) = do case findConstCaseType alts of
                                          Right (IntLikeCase ty) => getInstForConstCaseIntLike ty r alts def
                                          Right BigIntCase => getInstForConstCaseInteger r alts def
                                          Right StringCase => getInstForConstCaseString r alts def
                                          Right CharCase => getInstForConstCaseChar r alts def
                                          Left err => addError ("constcase error: " ++ err)
                                      forgetAllValuesConst

getInstIR {conNames} (CASE r alts def) =
  do let def' = fromMaybe [(ERROR $ "no default in CASE")] def


@@ 1020,7 1021,7 @@ getInstIR {conNames} (CASE r alts def) =
     appendCode $ "br label %" ++ labelEnd
     traverse_ (makeCaseAlt caseId) alts
     appendCode $ labelEnd ++ ":"
     pure ()
     forgetAllValuesConst
  where
    makeCaseAlt : String -> (Either Int Name, List VMInst) -> Codegen ()
    makeCaseAlt caseId (Left c, is) = do


@@ 1094,6 1095,15 @@ getFunIR conNames n args body = do
    traverse_ getInstIRWithComment body
    funcReturn
    appendCode "}\n"

    let closureEntryName = if cast (length args) <= FAT_CLOSURE_LIMIT
                              then safeName n
                              else (safeName n) ++ "$$closureEntry"
    let closureEntryType = if cast (length args) <= FAT_CLOSURE_LIMIT
                              then "%FuncPtrArgs" ++ show (length args)
                              else "%FuncPtrClosureEntry"
    let closureHeader = constHeader OBJECT_TYPE_ID_CLOSURE (0x10000 * (cast $ length args))
    appendCode $ "@" ++ safeName n ++ "$$closureNoArgs = private unnamed_addr addrspace(1) constant {i64, %FuncPtr} {" ++ toIR closureHeader ++ ", %FuncPtr bitcast (\{closureEntryType} @\{closureEntryName} to %FuncPtr)}, align 8\n"
  where
    copyArg : Reg -> String
    copyArg (Loc i) = let r = show i in "  %v" ++ r ++ "Var = alloca %ObjPtr\n  store %ObjPtr %v" ++ r ++ ", %ObjPtr* %v" ++ r ++ "Var"


@@ 1148,7 1158,7 @@ getVMIR _ _ (i, (n, MkVMError is)) = ""
funcPtrTypes : String
funcPtrTypes = fastConcat $ map funcPtr (rangeFromTo 0 FAT_CLOSURE_LIMIT) where
  funcPtr : Int -> String
  funcPtr i = "%FuncPtrArgs" ++ (show (i + 1)) ++ " = type %Return1 (%RuntimePtr, %TSOPtr, %RuntimePtr" ++ repeatStr ", %ObjPtr" (integerToNat $ cast (i+1)) ++ ")*\n"
  funcPtr i = "%FuncPtrArgs" ++ (show i) ++ " = type %Return1 (%RuntimePtr, %TSOPtr, %RuntimePtr" ++ repeatStr ", %ObjPtr" (integerToNat $ cast i) ++ ")*\n"

applyClosureHelperFunc : Codegen ()
applyClosureHelperFunc = do

M src/Compiler/LLVM/Rapid/Builtin.idr => src/Compiler/LLVM/Rapid/Builtin.idr +63 -62
@@ 4,7 4,6 @@ import Data.Vect
import System.Info

import Core.Name
import Compiler.VMCode

import Compiler.LLVM.IR
import Compiler.LLVM.Instruction


@@ 17,29 16,23 @@ import Rapid.Common
-- we provide our own in Data.Utils
%hide Core.Name.Namespace.showSep

-- TODO: in this file, reg2val is only ever used with RVal, refactor
reg2val : Reg -> IRValue (Pointer 0 IRObjPtr)
reg2val (Loc i) = SSA (Pointer 0 IRObjPtr) ("%v" ++ show i ++ "Var")
reg2val RVal = SSA (Pointer 0 IRObjPtr) ("%rvalVar")
reg2val Discard = IRDiscard

mk_prim__bufferNew : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferNew : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferNew [sizeObj, _] = do
  size <- unboxInt' sizeObj
  -- TODO: safety check: size < 2^32
  hdrValue <- mkHeader OBJECT_TYPE_ID_BUFFER !(mkTrunc size)
  newObj <- dynamicAllocate size
  putObjectHeader newObj hdrValue
  store newObj (reg2val RVal)
  pure newObj

mk_prim__bufferSize : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSize : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSize [arg0] = do
  hdr <- getObjectHeader arg0
  size <- mkAnd hdr (ConstI64 0xffffffff)
  sizeInt <- cgMkInt size
  store sizeInt (reg2val RVal)
  pure sizeInt

mk_prim__bufferGetByte : Vect 3 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetByte : Vect 3 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetByte [buf, offsetObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 49,9 42,9 @@ mk_prim__bufferGetByte [buf, offsetObj, _] = do
  bytePtr <- getElementPtr payloadStart offset
  byte <- load bytePtr
  val <- mkZext {to=I64} byte
  store !(cgMkInt val) (reg2val RVal)
  cgMkInt val

mk_prim__bufferSetByte : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetByte : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetByte [buf, offsetObj, valObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 61,8 54,9 @@ mk_prim__bufferSetByte [buf, offsetObj, valObj, _] = do
  bytePtr <- getElementPtr payloadStart offset
  val <- mkTrunc {to=I8} !(unboxInt' valObj)
  store val bytePtr
  mkUnit

mk_prim__bufferGetDouble : Vect 3 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetDouble : Vect 3 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetDouble [buf, offsetObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 72,9 66,9 @@ mk_prim__bufferGetDouble [buf, offsetObj, _] = do
  bytePtr <- getElementPtr payloadStart offset
  doublePtr <- bitcastA {n=1} bytePtr
  val <- load doublePtr
  store !(cgMkDouble val) (reg2val RVal)
  cgMkDouble val

mk_prim__bufferSetDouble : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetDouble : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetDouble [buf, offsetObj, valObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 85,8 79,9 @@ mk_prim__bufferSetDouble [buf, offsetObj, valObj, _] = do
  doublePtr <- bitcastA {n=1} bytePtr
  val <- unboxFloat64' valObj
  store val doublePtr
  mkUnit

mk_prim__bufferGetInt : Vect 3 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetInt : Vect 3 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetInt [buf, offsetObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 96,9 91,9 @@ mk_prim__bufferGetInt [buf, offsetObj, _] = do
  bytePtr <- getElementPtr payloadStart offset
  intPtr <- bitcastA {to=I64} {n=1} bytePtr
  val <- load intPtr
  store !(cgMkInt val) (reg2val RVal)
  cgMkInt val

mk_prim__bufferGetInt32 : Vect 3 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetInt32 : Vect 3 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetInt32 [buf, offsetObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 109,9 104,9 @@ mk_prim__bufferGetInt32 [buf, offsetObj, _] = do
  intPtr <- bitcastA {to=I32} {n=1} bytePtr
  val32 <- load intPtr
  val <- mkZext val32
  store !(cgMkInt val) (reg2val RVal)
  cgMkInt val

mk_prim__bufferSetInt : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetInt : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetInt [buf, offsetObj, valObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 122,8 117,9 @@ mk_prim__bufferSetInt [buf, offsetObj, valObj, _] = do
  intPtr <- bitcastA {to=I64} {n=1} bytePtr
  val <- unboxInt' valObj
  store val intPtr
  mkUnit

mk_prim__bufferSetInt32 : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetInt32 : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetInt32 [buf, offsetObj, valObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 134,8 130,9 @@ mk_prim__bufferSetInt32 [buf, offsetObj, valObj, _] = do
  intPtr <- bitcastA {to=I32} {n=1} bytePtr
  val <- mkTrunc {to=I32} !(unboxInt' valObj)
  store val intPtr
  mkUnit

mk_prim__bufferGetBits16 : Vect 3 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetBits16 : Vect 3 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetBits16 [buf, offsetObj, _] = do
  -- TODO: this assumes little-endian target architecture
  -- TODO: size check in safe mode


@@ 147,9 144,9 @@ mk_prim__bufferGetBits16 [buf, offsetObj, _] = do
  bitsPtr <- bitcastA {to=I16} {n=1} bytePtr
  valRaw <- load bitsPtr
  val <- mkZext valRaw
  store !(cgMkInt val) (reg2val RVal)
  cgMkInt val

mk_prim__bufferSetBits16 : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetBits16 : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetBits16 [buf, offsetObj, valObj, _] = do
  -- TODO: this assumes little-endian target architecture
  -- TODO: size check in safe mode


@@ 161,9 158,9 @@ mk_prim__bufferSetBits16 [buf, offsetObj, valObj, _] = do
  bitsPtr <- bitcastA {to=I16} {n=1} bytePtr
  val <- mkTrunc {to=I16} !(unboxInt' valObj)
  store val bitsPtr
  mkUnit


mk_prim__bufferGetString : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferGetString : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferGetString [buf, offsetObj, lengthObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 178,9 175,9 @@ mk_prim__bufferGetString [buf, offsetObj, lengthObj, _] = do
  putObjectHeader newStr newHeader
  strPayload <- getObjectPayloadAddr {t=I8} newStr
  appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR strPayload ++ ", " ++ toIR bytePtr ++ ", " ++ toIR length ++ ", i1 false)"
  store newStr (reg2val RVal)
  pure newStr

mk_prim__bufferSetString : Vect 4 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferSetString : Vect 4 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferSetString [buf, offsetObj, valObj, _] = do
  -- TODO: size check in safe mode
  --hdr <- getObjectHeader buf


@@ 191,9 188,9 @@ mk_prim__bufferSetString [buf, offsetObj, valObj, _] = do
  strLength <- mkZext {to=I64} !(getStringByteLength valObj)
  strPayload <- getObjectPayloadAddr {t=I8} valObj
  appendCode $ "  call void @llvm.memcpy.p1i8.p1i8.i64(" ++ toIR bytePtr ++ ", " ++ toIR strPayload ++ ", " ++ toIR strLength ++ ", i1 false)"
  mkUnit


mk_prim__bufferCopyData : Vect 6 (IRValue IRObjPtr) -> Codegen ()
mk_prim__bufferCopyData : Vect 6 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__bufferCopyData [src, startObj, lenObj, dest, locObj, _] = do
  start <- unboxInt' startObj
  len <- unboxInt' lenObj


@@ 205,8 202,9 @@ mk_prim__bufferCopyData [src, startObj, lenObj, dest, locObj, _] = do
  dstPtr <- getElementPtr dstPayloadStart loc

  appendCode $ "  call void @llvm.memmove.p1i8.p1i8.i64(" ++ toIR dstPtr ++ ", " ++ toIR srcPtr ++ ", " ++ toIR len ++ ", i1 false)"
  mkUnit

mk_prim__nullAnyPtr : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__nullAnyPtr : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__nullAnyPtr [p] = do
  lblStart <- genLabel "nullAnyPtr_start"
  lblInside <- genLabel "nullAnyPtr_inside"


@@ 227,55 225,58 @@ mk_prim__nullAnyPtr [p] = do
  beginLabel lblEnd
  isNullPtr <- phi [(ptrObjIsZero, lblStart), (payloadIsZero, lblInside)]
  result <- cgMkInt !(mkZext isNullPtr)
  store result (reg2val RVal)
  pure result

mk_prim__getString : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__getString : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__getString [p] = do
  assertObjectType' p OBJECT_TYPE_ID_POINTER
  payload <- getObjectSlot {t=IRObjPtr} p 0
  assertObjectType' payload OBJECT_TYPE_ID_STR
  store payload (reg2val RVal)
  pure payload

mk_prim__noop2 : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__noop2 : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__noop2 [_, _] = do
  store !(mkUnit) (reg2val RVal)
  mkUnit

mk_prim__currentDir : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__currentDir : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__currentDir [_] = do
  dummy <- mkStr "/tmp"
  newPtr <- dynamicAllocate (Const I64 8)
  putObjectHeader newPtr (constHeader OBJECT_TYPE_ID_POINTER 0)
  putObjectSlot newPtr (Const I64 0) dummy
  store newPtr (reg2val RVal)
  pure newPtr

mk_prelude_fastPack : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prelude_fastPack : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prelude_fastPack [charListObj] = do
  newObj <- foreignCall {t=IRObjPtr} "@rapid_fast_pack" [toIR charListObj]
  store newObj (reg2val RVal)
  pure newObj

mk_prelude_fastAppend : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prelude_fastAppend : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prelude_fastAppend [stringListObj] = do
  newObj <- foreignCall {t=IRObjPtr} "@rapid_fast_append" [toIR stringListObj]
  store newObj (reg2val RVal)
  pure newObj

TAG_LIST_NIL : IRValue I32
TAG_LIST_NIL = Const I32 0
TAG_LIST_CONS : IRValue I32
TAG_LIST_CONS = Const I32 1

mk_prelude_fastUnpack : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prelude_fastUnpack : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prelude_fastUnpack [strObj] = do
  nilHdr <- mkHeader OBJECT_TYPE_ID_CON_NO_ARGS TAG_LIST_NIL
  nilObj <- dynamicAllocate (Const I64 0)
  putObjectHeader nilObj nilHdr
  store nilObj (reg2val RVal)

  startLbl <- genLabel "start"
  returnLbl <- genLabel "ret"
  loopInitLbl <- genLabel "li"
  loopStartLbl <- genLabel "ls"
  loopBodyLbl <- genLabel "ls"
  loopEndLbl <- genLabel "le"

  jump startLbl
  beginLabel startLbl

  stringByteLength <- getStringByteLength strObj
  isEmpty <- icmp "eq" stringByteLength (Const I32 0)
  branch isEmpty returnLbl loopInitLbl


@@ 315,30 316,30 @@ mk_prelude_fastUnpack [strObj] = do

  beginLabel loopEndLbl
  putObjectSlot currentTail (Const I64 1) nilObj
  store resultObj (reg2val RVal)
  jump returnLbl

  beginLabel returnLbl
  phi [(nilObj, startLbl), (resultObj, loopEndLbl)]

TAG_UNCONS_RESULT_EOF : IRValue I32
TAG_UNCONS_RESULT_EOF = Const I32 0
TAG_UNCONS_RESULT_CHARACTER : IRValue I32
TAG_UNCONS_RESULT_CHARACTER = Const I32 1

mk_prim__stringIteratorNew : Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__stringIteratorNew : Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__stringIteratorNew [strObj] = do
  iterObj <- cgMkInt (Const I64 0)
  store iterObj (reg2val RVal)
  pure iterObj

mk_prim__stringIteratorNext : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__stringIteratorNext : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__stringIteratorNext [strObj, iteratorObj] = do
  offset <- unboxInt' iteratorObj
  strLength <- mkZext !(getStringByteLength strObj)
  mkIf_ (icmp "uge" offset strLength) (do
  mkIf (icmp "uge" offset strLength) (do
       eofObj <- dynamicAllocate (Const I64 0)
       hdr <- mkHeader OBJECT_TYPE_ID_CON_NO_ARGS TAG_UNCONS_RESULT_EOF
       putObjectHeader eofObj hdr
       store eofObj (reg2val RVal)
       pure eofObj
    ) (do
       resultObj <- dynamicAllocate (Const I64 16)
       hdrWithoutSize <- mkHeader OBJECT_TYPE_ID_CON_NO_ARGS TAG_UNCONS_RESULT_CHARACTER


@@ 358,7 359,7 @@ mk_prim__stringIteratorNext [strObj, iteratorObj] = do
       newOffset <- mkAdd !(mkZext decodedLength) offset
       newIter <- cgMkInt newOffset
       putObjectSlot resultObj (Const I64 1) newIter
       store resultObj (reg2val RVal)
       pure resultObj
    )

-- Needs to be kept in sync with time.c:


@@ 377,7 378,7 @@ CLOCK_TYPE_GCCPU = 6
CLOCK_TYPE_GCREAL : Int
CLOCK_TYPE_GCREAL = 7

mk_prim__readTime : Int -> Vect 1 (IRValue IRObjPtr) -> Codegen ()
mk_prim__readTime : Int -> Vect 1 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__readTime clockType [_] = do
  clock <- dynamicAllocate (Const I64 16)
  hdr <- mkHeader OBJECT_TYPE_ID_CLOCK (Const I32 0)


@@ 385,28 386,28 @@ mk_prim__readTime clockType [_] = do

  r <- foreignCall {t=I32} "@rapid_clock_read" [toIR clock, "i32 " ++ show clockType]

  store clock (reg2val RVal)
  pure clock

mk_prim__clockSecond : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__clockSecond : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__clockSecond [clockObj, _] = do
  secondsAddr <- getObjectSlotAddrVar {t=I64} clockObj (Const I64 0)
  seconds <- cgMkBits64 !(load secondsAddr)
  store seconds (reg2val RVal)
  pure seconds

mk_prim__clockNanoSecond : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__clockNanoSecond : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__clockNanoSecond [clockObj, _] = do
  nanoSecondsAddr <- getObjectSlotAddrVar {t=I64} clockObj (Const I64 1)
  nanoSeconds <- cgMkBits64 !(load nanoSecondsAddr)
  store nanoSeconds (reg2val RVal)
  pure nanoSeconds

mk_prim__clockIsValid : Vect 2 (IRValue IRObjPtr) -> Codegen ()
mk_prim__clockIsValid : Vect 2 (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mk_prim__clockIsValid [clockObj, _] = do
  -- clock objects store either "1" or "0" in the size field as validity flag
  valid <- cgMkInt !(mkZext !(getObjectSize clockObj))
  store valid (reg2val RVal)
  pure valid

export
builtinPrimitives : List (String, (n : Nat ** (Vect n (IRValue IRObjPtr) -> Codegen ())))
builtinPrimitives : List (String, (n : Nat ** (Vect n (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr))))
builtinPrimitives = [
    ("prim/blodwen-new-buffer", (2 ** mk_prim__bufferNew))
  , ("prim/blodwen-buffer-size", (1 ** mk_prim__bufferSize))

A src/Compiler/LLVM/Rapid/Closure.idr => src/Compiler/LLVM/Rapid/Closure.idr +49 -0
@@ 0,0 1,49 @@
module Compiler.LLVM.Rapid.Closure

import Core.Name

import Compiler.LLVM.IR
import Compiler.LLVM.Instruction
import Compiler.LLVM.Rapid.Object
import Control.Codegen
import Data.Utils

-- A "fat" closure is always invoked via its "closure entry" function
export
FAT_CLOSURE_LIMIT : Int
FAT_CLOSURE_LIMIT = 8

CLOSURE_MAX_ARGS : Int
CLOSURE_MAX_ARGS = 1024

export
mkClosure : Name -> Nat -> List (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr)
mkClosure n missingN [] =
  pure $ SSA IRObjPtr $ "bitcast ({i64, %FuncPtr} addrspace(1)* @\{safeName n}$$closureNoArgs to %ObjPtr)"

mkClosure n missingN args = do
  let missing = cast {to=Int} missingN
  let len = cast {to=Int} $ length args
  let totalArgsExpected = missing + len
  if totalArgsExpected > (cast CLOSURE_MAX_ARGS)
     then do
       addError $ "ERROR : too many closure arguments: " ++ show totalArgsExpected ++ " > " ++ show CLOSURE_MAX_ARGS
       pure nullPtr
     else do
  let header = constHeader OBJECT_TYPE_ID_CLOSURE (cast ((missing * 0x10000) + len))
  newObj <- dynamicAllocate (Const I64 $ cast (8 + 8 * len))
  putObjectHeader newObj header
  funcPtr <- (if (totalArgsExpected <= (cast FAT_CLOSURE_LIMIT))
             then
               assignSSA $ "bitcast %FuncPtrArgs" ++ show totalArgsExpected ++ " @" ++ (safeName n) ++ " to %FuncPtr"
             else do
               assignSSA $ "bitcast %FuncPtrClosureEntry @" ++ (safeName n) ++ "$$closureEntry to %FuncPtr"
               )

  putObjectSlot newObj (Const I64 0) (SSA FuncPtr funcPtr)
  for_ (enumerate args) (\iv => do
      let (i, argObj) = iv
      putObjectSlot newObj (Const I64 $ cast $ i+1) argObj
      pure ()
      )
  pure newObj

M src/Compiler/LLVM/Rapid/Foreign.idr => src/Compiler/LLVM/Rapid/Foreign.idr +3 -3
@@ 5,7 5,6 @@ import Data.String
import Data.Vect

import Compiler.CompileExpr
import Compiler.VMCode
import Core.Name

import Compiler.LLVM.IR


@@ 118,12 117,13 @@ missingForeign cs name argTypes = do
  appendCode "\n}\n"

export
builtinForeign : (n : Nat ** (Vect n (IRValue IRObjPtr) -> Codegen ())) -> Name -> (argTypes : List CFType) -> CFType -> Codegen ()
builtinForeign : (n : Nat ** (Vect n (IRValue IRObjPtr) -> Codegen (IRValue IRObjPtr))) -> Name -> (argTypes : List CFType) -> CFType -> Codegen ()
builtinForeign builtin name argTypes ret = do
  let (n ** f) = builtin
  appendCode ("define external fastcc %Return1 @" ++ safeName name ++ "(" ++ (showSep ", " $ prepareArgCallConv $ toList $ map toIR (args n)) ++ ") gc \"statepoint-example\" {")
  funcEntry
  f (args n)
  result <- f (args n)
  store result $ SSA (Pointer 0 IRObjPtr) ("%rvalVar")
  funcReturn
  appendCode "\n}\n"
  where

M src/Compiler/LLVM/Rapid/Object.idr => src/Compiler/LLVM/Rapid/Object.idr +8 -0
@@ 217,6 217,14 @@ mkCon tag args = do
  pure newObj

export
mkConstCon : Int -> List (String) -> Codegen (IRValue IRObjPtr)
mkConstCon tag args = do
  let newHeader = constHeader (OBJECT_TYPE_ID_CON_NO_ARGS + (256 * (cast $ length args))) (cast tag)
  let typeSignature = "{i64" ++ repeatStr ", %ObjPtr" (length args) ++ "}"
  cName <- addConstant $ "private unnamed_addr addrspace(1) constant " ++ typeSignature ++ " {" ++ toIR newHeader ++ (concat $ map ((++) ", ") args) ++ "}, align 8"
  pure $ SSA IRObjPtr $ "bitcast (" ++ typeSignature ++ " addrspace(1)* " ++ cName ++ " to %ObjPtr)"

export
cgMkDouble : IRValue F64 -> Codegen (IRValue IRObjPtr)
cgMkDouble val = do
  newObj <- dynamicAllocate (ConstI64 8)

M src/Control/Codegen.idr => src/Control/Codegen.idr +34 -12
@@ 4,6 4,8 @@ import public Control.Monad.State
import Data.List
import Data.String

import Libraries.Data.SortedMap

import Debug.Trace
import Rapid.Common



@@ 18,13 20,14 @@ record CGBuffer where
  consts : List ConstDef
  code : List String
  errors : List String
  constantValues : SortedMap Int String

public export
Codegen : Type -> Type
Codegen = State CGBuffer

emptyCG : CompileOpts -> CGBuffer
emptyCG opts = MkCGBuf opts 0 [] [] []
emptyCG opts = MkCGBuf opts 0 [] [] [] empty

export
getOpts : Codegen CompileOpts


@@ 32,30 35,31 @@ getOpts = (.opts) <$> get

export
appendCode : String -> Codegen ()
appendCode c = modify $ record { code $= (c::)}
appendCode c = modify { code $= (c::)}

export
getUnique : Codegen Int
getUnique = do
  (MkCGBuf o i c l e) <- get
  put (MkCGBuf o (i+1) c l e)
  st <- get
  let i = st.i
  put ({i := i+1} st)
  pure i

export
addConstant : String -> Codegen String
addConstant v = do
  ci <- getUnique
  (MkCGBuf o i c l e) <- get
  let name = "@glob_" ++ show (o.constNamespace) ++ "_c" ++ show ci
  put (MkCGBuf o i ((name, v)::c) l e)
  st <- get
  let name = "@glob_" ++ show (st.opts.constNamespace) ++ "_c" ++ show ci
  put ({ consts $= ((name, v)::)} st)
  pure name

export
addError : String -> Codegen ()
addError msg = do
  appendCode ("; ERROR: " ++ msg)
  (MkCGBuf o i c l e) <- get
  put $ trace ("add error: " ++ msg) (MkCGBuf o i c l (msg::e))
  st <- get
  put $ trace ("add error: " ++ msg) ({errors $= (msg::)} st)

export
addMetadata : String -> Codegen String


@@ 64,8 68,7 @@ addMetadata v = do
  u <- getUnique
  let mdId = u * 0x10000 + i
  let name = "!" ++ show mdId
  (MkCGBuf o i c l e) <- get
  put (MkCGBuf o i ((name, v)::c) l e)
  modify { consts $= ((name, v)::)}
  pure name

export


@@ 78,6 81,25 @@ appendMetadata value = do
  pure varname

export
trackValueConst : Int -> String -> Codegen ()
trackValueConst v c = do
  modify {constantValues $= insert v c}

export
removeValueConst : Int -> Codegen ()
removeValueConst v = do
  modify {constantValues $= delete v}

export
isValueConst : Int -> Codegen (Maybe String)
isValueConst v = do
  lookup v . (.constantValues) <$> get

export
forgetAllValuesConst : Codegen ()
forgetAllValuesConst = modify {constantValues := empty}

export
mkVarName : String -> Codegen String
mkVarName pfx = do
  i <- getUnique


@@ 85,5 107,5 @@ mkVarName pfx = do

export
runCodegen : CompileOpts -> Codegen () -> String
runCodegen o r = let (MkCGBuf _ _ cs ls errors) = fst $ runState (emptyCG o) r in
runCodegen o r = let (MkCGBuf _ _ cs ls errors _) = fst $ runState (emptyCG o) r in
                     fastConcat $ intersperse "\n" $ (map (\(n,v) => n ++ " = " ++ v) $ reverse cs) ++ reverse ls