6532865 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #381 from Ralith/llvm-immutable

6532865Edwin Brady13 years ago

idris.cabal+1−1

compare with master

unifiedsplit

@@ -272,7 +272,7 @@ Executable idris

272 haskeline>=0.7, split, directory,

273 containers, process, transformers, filepath,

274 directory, binary, bytestring, text, pretty,

275− language-java>=0.2.2, libffi, llvm-general==3.3.3.*,

275+ language-java>=0.2.2, libffi, llvm-general>=3.3.4.1 && <3.3.5,

276 vector, vector-binary-instances

277

278 Extensions: MultiParamTypeClasses, FunctionalDependencies,

src/IRTS/CodegenLLVM.hs+23−13

@@ -161,6 +161,7 @@ initDefs tgt =

161 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i32" VoidType [ptrI8, ptrI8, IntegerType 32, IntegerType 32, IntegerType 1] False

162 -- , exfun "llvm.llvm.memcpy.p0i8.p0i8.i64" VoidType [ptrI8, ptrI8, IntegerType 64, IntegerType 32, IntegerType 1] False

163 , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False

164+ , exfun "llvm.invariant.start" (PointerType (StructureType False []) (AddrSpace 0)) [IntegerType 64, ptrI8] False

164 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True

165 , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True

165 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False

166 , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False

166 , exfun "strlen" intPtr [ptrI8] False

167 , exfun "strlen" intPtr [ptrI8] False

@@ -395,6 +396,9 @@ sizeOf ty = ConstantOperand . C.PtrToInt

395 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])

396 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])

396 . IntegerType <$> getWordSize

397 . IntegerType <$> getWordSize

397

398

399+loadInv :: Operand -> Instruction

400+loadInv ptr = Load False ptr Nothing 0 [("invariant.load", MetadataNode [])]

401+

398tgtWordSize :: Target -> Word32

402tgtWordSize :: Target -> Word32

399tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =

403tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =

400 fst . fromJust $ M.lookup (AddrSpace 0) l

404 fst . fromJust $ M.lookup (AddrSpace 0) l

@@ -423,7 +427,8 @@ cgExpr (SCon tag name args) = do

423 case sequence argSlots of

427 case sequence argSlots of

424 Nothing -> return Nothing

428 Nothing -> return Nothing

425 Just argVals -> do

429 Just argVals -> do

426− con <- alloc . conType . fromIntegral . length $ argVals

430+ let ty = conType . fromIntegral . length $ argVals

431+ con <- alloc ty

427 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

432 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

428 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []

433 inst' $ Store False tagPtr (ConstantOperand (C.Int 32 (fromIntegral tag))) Nothing 0 []

429 forM_ (zip argVals [0..]) $ \(arg, i) -> do

434 forM_ (zip argVals [0..]) $ \(arg, i) -> do

@@ -431,6 +436,8 @@ cgExpr (SCon tag name args) = do

431 , ConstantOperand (C.Int 32 1)

436 , ConstantOperand (C.Int 32 1)

432 , ConstantOperand (C.Int 32 i)] []

437 , ConstantOperand (C.Int 32 i)] []

433 inst' $ Store False ptr arg Nothing 0 []

438 inst' $ Store False ptr arg Nothing 0 []

439+ ptrI8 <- inst $ BitCast con (PointerType (IntegerType 8) (AddrSpace 0)) []

440+ inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]

434 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])

441 Just <$> inst (BitCast con (PointerType valueType (AddrSpace 0)) [])

435cgExpr (SCase inspect alts) = do

442cgExpr (SCase inspect alts) = do

436 val <- var inspect

443 val <- var inspect

@@ -449,7 +456,7 @@ cgExpr (SChkCase inspect alts) = do

449 terminate $ CondBr isNull endBBN notNullBBN []

456 terminate $ CondBr isNull endBBN notNullBBN []

450 newBlock notNullBBN

457 newBlock notNullBBN

451 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []

458 ptr <- inst $ BitCast val (PointerType (IntegerType 32) (AddrSpace 0)) []

452− flag <- inst $ Load False ptr Nothing 0 []

459+ flag <- inst $ loadInv ptr

453 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []

460 isVal <- inst $ ICmp IPred.EQ flag (ConstantOperand (C.Int 32 (-1))) []

454 conBBN <- getName "constructor"

461 conBBN <- getName "constructor"

455 terminate $ CondBr isVal endBBN conBBN []

462 terminate $ CondBr isVal endBBN conBBN []

@@ -476,7 +483,7 @@ cgExpr (SProj conVar idx) = do

476 , ConstantOperand (C.Int 32 1)

483 , ConstantOperand (C.Int 32 1)

477 , ConstantOperand (C.Int 32 (fromIntegral idx))

484 , ConstantOperand (C.Int 32 (fromIntegral idx))

478 ] []

485 ] []

479− Just <$> inst (Load False ptr Nothing 0 [])

486+ Just <$> inst (loadInv ptr)

480cgExpr (SConst c) = Just <$> cgConst c

487cgExpr (SConst c) = Just <$> cgConst c

481cgExpr (SForeign LANG_C rty fname args) = do

488cgExpr (SForeign LANG_C rty fname args) = do

482 func <- ensureCDecl fname rty (map fst args)

489 func <- ensureCDecl fname rty (map fst args)

@@ -555,7 +562,7 @@ cgPrimCase caseValPtr defExp alts = do

555 SConstCase (TT.Ch _) _ -> IntegerType 32

562 SConstCase (TT.Ch _) _ -> IntegerType 32

556 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []

563 realPtr <- inst $ BitCast caseValPtr (PointerType (primTy caseTy) (AddrSpace 0)) []

557 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

564 valPtr <- inst $ GetElementPtr True realPtr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

558− caseVal <- inst $ Load False valPtr Nothing 0 []

565+ caseVal <- inst $ loadInv valPtr

559 defBlockName <- getName "default"

566 defBlockName <- getName "default"

560 exitBlockName <- getName "caseExit"

567 exitBlockName <- getName "caseExit"

561 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts

568 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts

@@ -568,7 +575,7 @@ cgPrimCase caseValPtr defExp alts = do

568cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

575cgConCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

569cgConCase con defExp alts = do

576cgConCase con defExp alts = do

570 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

577 tagPtr <- inst $ GetElementPtr True con [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

571− tag <- inst $ Load False tagPtr Nothing 0 []

578+ tag <- inst $ loadInv tagPtr

572 defBlockName <- getName "default"

579 defBlockName <- getName "default"

573 exitBlockName <- getName "caseExit"

580 exitBlockName <- getName "caseExit"

574 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts

581 namedAlts <- mapM (\a -> do n <- nameAlt defBlockName a; return (n, a)) alts

@@ -654,7 +661,7 @@ cgAlt initEnv exitBlockName name destr exp = do

654 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)

661 do ptr <- inst $ GetElementPtr True con [ ConstantOperand (C.Int 32 0)

655 , ConstantOperand (C.Int 32 1)

662 , ConstantOperand (C.Int 32 1)

656 , ConstantOperand (C.Int 32 i)] []

663 , ConstantOperand (C.Int 32 i)] []

657− Just <$> ninst argName (Load False ptr Nothing 0 [])

664+ Just <$> ninst argName (loadInv ptr)

658 altVal <- binds locals $ cgExpr exp

665 altVal <- binds locals $ cgExpr exp

659 altEnv <- gets lexenv

666 altEnv <- gets lexenv

660 altBlock <- gets currentBlockName

667 altBlock <- gets currentBlockName

@@ -690,11 +697,14 @@ nameAlt _ (SConstCase const _) = getName (show const)

690box :: FType -> Operand -> Codegen Operand

697box :: FType -> Operand -> Codegen Operand

691box FUnit _ = return $ ConstantOperand nullValue

698box FUnit _ = return $ ConstantOperand nullValue

692box fty fval = do

699box fty fval = do

700+ let ty = primTy (ftyToTy fty)

693− val <- alloc (primTy (ftyToTy fty))

701+ val <- alloc ty

694 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

702 tagptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] []

695 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

703 valptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

696 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []

704 inst' $ Store False tagptr (ConstantOperand (C.Int 32 (-1))) Nothing 0 []

697 inst' $ Store False valptr fval Nothing 0 []

705 inst' $ Store False valptr fval Nothing 0 []

706+ ptrI8 <- inst $ BitCast val (PointerType (IntegerType 8) (AddrSpace 0)) []

707+ inst' $ simpleCall "llvm.invariant.start" [ConstantOperand $ C.Int 64 (-1), ptrI8]

698 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []

708 inst $ BitCast val (PointerType valueType (AddrSpace 0)) []

699

709

700unbox :: FType -> Operand -> Codegen Operand

710unbox :: FType -> Operand -> Codegen Operand

@@ -702,7 +712,7 @@ unbox FUnit x = return x

702unbox fty bval = do

712unbox fty bval = do

703 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []

713 val <- inst $ BitCast bval (PointerType (primTy (ftyToTy fty)) (AddrSpace 0)) []

704 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

714 fvalptr <- inst $ GetElementPtr True val [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] []

705− inst $ Load False fvalptr Nothing 0 []

715+ inst $ loadInv fvalptr

706

716

707cgConst' :: TT.Const -> C.Constant

717cgConst' :: TT.Const -> C.Constant

708cgConst' (TT.I i) = C.Int 32 (fromIntegral i)

718cgConst' (TT.I i) = C.Int 32 (fromIntegral i)

@@ -954,7 +964,7 @@ cgOp LStrCons [c,s] = do

954

964

955cgOp LStrHead [c] = do

965cgOp LStrHead [c] = do

956 s <- unbox FString c

966 s <- unbox FString c

957− c <- inst $ Load False s Nothing 0 []

967+ c <- inst $ loadInv s

958 c' <- inst $ ZExt c (IntegerType 32) []

968 c' <- inst $ ZExt c (IntegerType 32) []

959 box FChar c'

969 box FChar c'

960

970

@@ -962,7 +972,7 @@ cgOp LStrIndex [s, i] = do

962 ns <- unbox FString s

972 ns <- unbox FString s

963 ni <- unbox (FArith (ATInt (ITFixed IT32))) i

973 ni <- unbox (FArith (ATInt (ITFixed IT32))) i

964 p <- inst $ GetElementPtr True ns [ni] []

974 p <- inst $ GetElementPtr True ns [ni] []

965− c <- inst $ Load False p Nothing 0 []

975+ c <- inst $ loadInv p

966 c' <- inst $ ZExt c (IntegerType 32) []

976 c' <- inst $ ZExt c (IntegerType 32) []

967 box FChar c'

977 box FChar c'

968

978

@@ -988,15 +998,15 @@ cgOp LReadStr [p] = do

988

998

989cgOp LStdIn [] = do

999cgOp LStdIn [] = do

990 stdin <- getStdIn

1000 stdin <- getStdIn

991− ptr <- inst $ Load False stdin Nothing 0 []

1001+ ptr <- inst $ loadInv stdin

992 box FPtr ptr

1002 box FPtr ptr

993cgOp LStdOut [] = do

1003cgOp LStdOut [] = do

994 stdout <- getStdOut

1004 stdout <- getStdOut

995− ptr <- inst $ Load False stdout Nothing 0 []

1005+ ptr <- inst $ loadInv stdout

996 box FPtr ptr

1006 box FPtr ptr

997cgOp LStdErr [] = do

1007cgOp LStdErr [] = do

998 stdErr <- getStdErr

1008 stdErr <- getStdErr

999− ptr <- inst $ Load False stdErr Nothing 0 []

1009+ ptr <- inst $ loadInv stdErr

1000 box FPtr ptr

1010 box FPtr ptr

1001

1011

1002cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("

1012cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("