6861795 · Idris-dev · git.iko.soy

196 (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)

197 entryTerm = case bbs of

198 [] -> Do $ Ret Nothing []

199− (BasicBlock n _ _):_ -> Do $ Br n []

199+ BasicBlock n _ _:_ -> Do $ Br n []

200 tell globals

201 put nextGlobal'

202 return . GlobalDefinition $ functionDefaults

208 Parameter (PointerType valueType (AddrSpace 0)) (Name (show argName)) []

209 , False)

210 , G.basicBlocks =

211− [ BasicBlock (Name "entry")

211+ BasicBlock (Name "entry")

212− (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)

212+ (map (\(n, t) -> n := Alloca t Nothing 0 []) allocas)

213− entryTerm

213+ entryTerm

214− ] ++ bbs

214+ : bbs

215 }

216

217type CGW = ([(Name, Type)], [BasicBlock], [Definition])

301replaceElt n val (x:xs) = x : replaceElt (n-1) val xs

302

303alloc' :: Operand -> Codegen Operand

304−alloc' size = do

305− inst $ simpleCall "GC_malloc" [size]

304+alloc' size = inst $ simpleCall "GC_malloc" [size]

306

305

307allocAtomic :: Operand -> Codegen Operand

306allocAtomic :: Operand -> Codegen Operand

308−allocAtomic size = do

309− inst $ simpleCall "GC_malloc_atomic" [size]

307+allocAtomic size = inst $ simpleCall "GC_malloc_atomic" [size]

310

308

311alloc :: Type -> Codegen Operand

309alloc :: Type -> Codegen Operand

312alloc ty = do

310alloc ty = do

335 Nothing -> return Nothing

333 Nothing -> return Nothing

336 Just argVals -> do

334 Just argVals -> do

337 fn <- var (Glob fname)

335 fn <- var (Glob fname)

338− Just <$> (inst $

336+ Just <$> inst

339− Call { isTailCall = tailcall

337+ Call { isTailCall = tailcall

340− , callingConvention = CC.Fast

338+ , callingConvention = CC.Fast

341− , returnAttributes = []

339+ , returnAttributes = []

342− , function = Right . ConstantOperand . C.GlobalReference . Name $ show fname

340+ , function = Right . ConstantOperand . C.GlobalReference . Name $ show fname

343− , arguments = map (\v -> (v, [])) argVals

341+ , arguments = map (\v -> (v, [])) argVals

344− , functionAttributes = []

342+ , functionAttributes = []

345− , metadata = []

343+ , metadata = []

346− })

344+ }

347cgExpr (SLet _ varExpr bodyExpr) = do

345cgExpr (SLet _ varExpr bodyExpr) = do

348 val <- cgExpr varExpr

346 val <- cgExpr varExpr

349 binds [val] $ cgExpr bodyExpr

347 binds [val] $ cgExpr bodyExpr

364 , ConstantOperand (C.Int 32 1)

362 , ConstantOperand (C.Int 32 1)

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

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

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

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

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

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

368cgExpr (SCase inspect alts) = do

366cgExpr (SCase inspect alts) = do

369 val <- var inspect

367 val <- var inspect

370 case val of

368 case val of

397 Just caseVal -> do

395 Just caseVal -> do

398 terminate $ Br endBBN []

396 terminate $ Br endBBN []

399 newBlock endBBN

397 newBlock endBBN

400− Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))

398+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0))

401 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])

399 [(val, originBlock), (val, notNullBBN), (caseVal, caseExitBlock)] [])

402cgExpr (SProj conVar idx) = do

400cgExpr (SProj conVar idx) = do

403 val <- var conVar

401 val <- var conVar

409 , ConstantOperand (C.Int 32 1)

407 , ConstantOperand (C.Int 32 1)

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

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

411 ] []

409 ] []

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

410+ Just <$> inst (Load False ptr Nothing 0 [])

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

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

414cgExpr (SForeign LANG_C rty fname args) = do

412cgExpr (SForeign LANG_C rty fname args) = do

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

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

422 Nothing -> return Nothing

420 Nothing -> return Nothing

423 Just argVals' -> do

421 Just argVals' -> do

424 argUVals <- mapM (uncurry unbox) argVals'

422 argUVals <- mapM (uncurry unbox) argVals'

425− result <- inst $ Call { isTailCall = False

423+ result <- inst Call { isTailCall = False

426− , callingConvention = CC.C

424+ , callingConvention = CC.C

427− , returnAttributes = []

425+ , returnAttributes = []

428− , function = Right func

426+ , function = Right func

429− , arguments = map (\v -> (v, [])) argUVals

427+ , arguments = map (\v -> (v, [])) argUVals

430− , functionAttributes = []

428+ , functionAttributes = []

431− , metadata = []

429+ , metadata = []

432− }

430+ }

433 Just <$> box rty result

431 Just <$> box rty result

434cgExpr (SOp fn args) = do

432cgExpr (SOp fn args) = do

435 argVals <- mapM var args

433 argVals <- mapM var args

442 (cgConst' (TT.Str (msg ++ "\n")))

440 (cgConst' (TT.Str (msg ++ "\n")))

443 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0

441 inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0

444 , C.Int 32 0]]

442 , C.Int 32 0]]

445− inst' $ Call { isTailCall = True

443+ inst' Call { isTailCall = True

446− , callingConvention = CC.C

444+ , callingConvention = CC.C

447− , returnAttributes = []

445+ , returnAttributes = []

448− , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"

446+ , function = Right . ConstantOperand . C.GlobalReference . Name $ "llvm.trap"

449− , arguments = []

447+ , arguments = []

450− , functionAttributes = [A.NoReturn]

448+ , functionAttributes = [A.NoReturn]

451− , metadata = []

449+ , metadata = []

452− }

450+ }

453 return Nothing

451 return Nothing

454

452

455cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)

453cgCase :: Operand -> [SAlt] -> Codegen (Maybe Operand)

464 constAlts = filter isConstCase alts

462 constAlts = filter isConstCase alts

465 conAlts = filter isConCase alts

463 conAlts = filter isConCase alts

466

464

467− isConstCase (SConstCase _ _) = True

465+ isConstCase (SConstCase {}) = True

468 isConstCase _ = False

466 isConstCase _ = False

469

467

470− isConCase (SConCase _ _ _ _ _) = True

468+ isConCase (SConCase {}) = True

471 isConCase _ = False

469 isConCase _ = False

472

470

473 isDefCase (SDefaultCase _) = True

471 isDefCase (SDefaultCase _) = True

510 initEnv <- gets lexenv

508 initEnv <- gets lexenv

511 defResult <- cgDefaultAlt exitBlockName defBlockName defExp

509 defResult <- cgDefaultAlt exitBlockName defBlockName defExp

512 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->

510 results <- forM namedAlts $ \(name, SConCase _ _ _ argns exp) ->

513− cgAlt initEnv exitBlockName name (Just (con, (map show argns))) exp

511+ cgAlt initEnv exitBlockName name (Just (con, map show argns)) exp

514 finishCase initEnv exitBlockName (defResult:results)

512 finishCase initEnv exitBlockName (defResult:results)

515

513

516cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

514cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)

564 xs -> do

562 xs -> do

565 newBlock exitBlockName

563 newBlock exitBlockName

566 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs

564 mergeEnvs $ map (\(_, altBlock, altEnv) -> (altBlock, altEnv)) xs

567− Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0))

565+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0))

568 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])

566 (map (\(altVal, altBlock, _) -> (altVal, altBlock)) xs) [])

569

567

570

568

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

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

595 , ConstantOperand (C.Int 32 1)

593 , ConstantOperand (C.Int 32 1)

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

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

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

595+ Just <$> ninst argName (Load False ptr Nothing 0 [])

598 altVal <- binds locals $ cgExpr exp

596 altVal <- binds locals $ cgExpr exp

599 altEnv <- gets lexenv

597 altEnv <- gets lexenv

600 altBlock <- gets currentBlockName

598 altBlock <- gets currentBlockName

619 | all (== v) (map fst vs) -> return v

617 | all (== v) (map fst vs) -> return v

620 | otherwise ->

618 | otherwise ->

621 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in

619 let valid = map (\(a, b) -> (fromJust a, b)) . filter (isJust . fst) $ vs in

622− Just <$> (inst $ Phi (PointerType valueType (AddrSpace 0)) valid [])

620+ Just <$> inst (Phi (PointerType valueType (AddrSpace 0)) valid [])

623 modify $ \s -> s { lexenv = env }

621 modify $ \s -> s { lexenv = env }

624

622

625nameAlt :: Name -> SAlt -> Codegen Name

623nameAlt :: Name -> SAlt -> Codegen Name

764

762

765cgOp LStrConcat [x,y] = cgStrCat x y

763cgOp LStrConcat [x,y] = cgStrCat x y

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

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

767− ++ (intersperse ',' $ take (length args) ['a'..]) ++ ")"

765+ ++ intersperse ',' (take (length args) ['a'..]) ++ ")"

768

766

769cgStrCat :: Operand -> Operand -> Codegen Operand

767cgStrCat :: Operand -> Operand -> Codegen Operand

770cgStrCat x y = do

768cgStrCat x y = do