~cypheon/rapid: Merge branch 'main' into new-alloc

8 files changed, 201 insertions(+), 169 deletions(-)

M CMakeLists.txt
D scratch.md
M src/Compiler/GenLLVMIR.idr
M src/Compiler/LLVM/Rapid/Builtin.idr
A src/Compiler/LLVM/Rapid/Closure.idr
M src/Compiler/LLVM/Rapid/Foreign.idr
M src/Compiler/LLVM/Rapid/Object.idr
M src/Control/Codegen.idr

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