~cypheon/rapid

61aec3ca4e09d39e3a83bc4487c4fcddba786444 — Johann Rudloff 26 days ago 9928b2e main
Turn Data Constructors with constant members into constants

When all arguments of a Data Constructor are constants, the created
object will also be a constant.  For now this is only tracked for
closures without arguments and helps to avoid some allocations when
records for interfaces are created. (As they only contain funtion
pointers without arguments.)
3 files changed, 61 insertions(+), 5 deletions(-)

M src/Compiler/GenLLVMIR.idr
M src/Compiler/LLVM/Rapid/Object.idr
M src/Control/Codegen.idr
M src/Compiler/GenLLVMIR.idr => src/Compiler/GenLLVMIR.idr +29 -3
@@ 143,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


@@ 891,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


@@ 906,6 927,10 @@ getInstIR (MKCLOSURE r n missingN args) = do
  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"


@@ 972,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


@@ 995,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

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 +24 -2
@@ 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


@@ 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