a98444c · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Removed some unnecessary closures

a98444cJan Bessai14 years ago

java/src/main/java/org/idris/rts/ForeignPrimitives.java+16

compare with master

unifiedsplit

@@ -195,4 +195,20 @@ public class ForeignPrimitives {

195 public static int isNull(Object o) {

196 return (o == null ? 1 : 0);

197 }

198+

199+ public final static Object idris_K(final Object result, final Object drop) {

200+ return result;

201+ }

202+

203+ public final static Object idris_flipK(final Object drop, final Object result) {

204+ return result;

205+ }

206+

207+ public final static Object idris_assignStack(final Object [] context, final int start, final Object ... vars) {

208+ int i = start;

209+ for (Object var : vars) {

210+ context[i] = var;

211+ }

212+ return context;

213+ }

198}

214}

src/IRTS/CodegenJava.hs+107−104

@@ -300,6 +300,9 @@ mkIdentifier (UN name) =

300 cleanReserved "fputStr" = "_fputStr"

301 cleanReserved "fileEOF" = "_fileEOF"

302 cleanReserved "isNull" = "_isNull"

303+ cleanReserved "idris_K" = "_idris_K"

304+ cleanReserved "idris_flipK" = "_idris_flipK"

305+ cleanReserved "idris_assignStack" = "_idris_assignStack"

303

306

304 cleanReserved x = x

307 cleanReserved x = x

305

308

@@ -376,19 +379,29 @@ mkDecl ((NS n (ns:nss)), decl) =

376 <$> mkIdentifier (UN ns)

379 <$> mkIdentifier (UN ns)

377 <*> mkClassBody [(NS n nss, decl)]

380 <*> mkClassBody [(NS n nss, decl)]

378mkDecl (_, SFun name params stackSize body) =

381mkDecl (_, SFun name params stackSize body) =

379− (\ name params cont ->

382+ (\ name params paramNames methodBody ->

380 MemberDecl $ MethodDecl [Public, Static]

383 MemberDecl $ MethodDecl [Public, Static]

381 []

384 []

382 (Just . RefType $ ClassRefType objectType)

385 (Just . RefType $ ClassRefType objectType)

383 name

386 name

384 params

387 params

385 []

388 []

386− (MethodBody . Just $ Block [ BlockStmt . Return . Just . MethodInv $

389+ (MethodBody . Just $ Block

387− PrimaryMethodCall cont [] (Ident "call") []])

390+ [ LocalVars [Final]

391+ objectArrayType

392+ [ VarDecl (VarDeclArray . VarId $ Ident "context")

393+ (Just . InitArray . ArrayInit $

394+ paramNames

395+ ++ replicate stackSize (InitExp . Lit $ Null))

396+ ]

397+ , BlockStmt . Return $ Just methodBody

398+ ]

399+ )

388 )

400 )

389 <$> mkIdentifier name

401 <$> mkIdentifier name

390 <*> mapM mkFormalParam params

402 <*> mapM mkFormalParam params

391− <*> mkClosure params stackSize body

403+ <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params

404+ <*> mkExp body

392

405

393

406

394mkClosure :: [Name] -> Int -> SExp -> Either String Exp

407mkClosure :: [Name] -> Int -> SExp -> Either String Exp

@@ -424,99 +437,28 @@ mkStackInit params stackSize =

424 ++ (replicate (stackSize) (InitExp $ Lit Null)))

437 ++ (replicate (stackSize) (InitExp $ Lit Null)))

425 <$> mapM mkName params

438 <$> mapM mkName params

426

439

427−mkAnonymousLetBinding :: LVar -> SExp -> SExp -> Either String Exp

440+mkK :: Exp -> Exp -> Exp

428−mkAnonymousLetBinding var oldExp newExp =

441+mkK result drop =

429− (\ bindingMethod newExp ->

442+ MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]

430− MethodInv $ PrimaryMethodCall

443+

431− ( MethodInv $ PrimaryMethodCall ( InstanceCreation []

444+mkFlipK :: Exp -> Exp -> Exp

432− objectType

445+mkFlipK drop result =

433− []

446+ MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]

434− (Just $ ClassBody [MemberDecl $ bindingMethod])

447+

435− )

436− []

437− (Ident "apply")

438− [ contextArray

439− , newExp]

440− )

441− []

442− (Ident "call")

443− []

444− )

445− <$> mkLetBindingMethod var oldExp

446− <*> mkExp newExp

447−

448−

449−mkContextParam :: FormalParam

450−mkContextParam =

451− FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))

452−

453−mkLetBindingMethod :: LVar -> SExp -> Either String MemberDecl

448+mkLet :: LVar -> SExp -> SExp -> Either String Exp

454−mkLetBindingMethod (Loc i) oldExp =

449+mkLet (Loc pos) oldExp newExp =

455− (\ param bindingStack oldCont ->

450+ (\ oldExp newExp ->

456− MethodDecl [Final, Public]

457− []

458− (Just . RefType $ ClassRefType idrisClosureType)

459− (Ident "apply")

460− [mkContextParam, param]

461− []

462− (MethodBody . Just . Block $

463− bindingStack ++ [BlockStmt . Return $ Just oldCont]

464− )

465− )

466− <$> mkFormalParam (UN "param")

467− <*> mkBindingStack True i [UN "param"]

468− <*> mkBindingClosure oldExp

469−

470−mkBindingClosure :: SExp -> Either String Exp

471−mkBindingClosure oldExp =

472− (\ oldCall ->

473− InstanceCreation []

474− idrisClosureType

475− [ ExpName $ J.Name [Ident "new_context"] ]

451+ mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])

476− (Just $ ClassBody [oldCall])

452+ (Lit $ Int (toInteger pos)))

453+ EqualA

454+ newExp

455+ )

456+ oldExp

477 )

457 )

478− <$> mkClosureCall oldExp

458+ <$> mkExp oldExp

479−

459+ <*> mkExp newExp

480

460

481−mkBindingStack :: Bool -> Int -> [Name] -> Either String [BlockStmt]

482−mkBindingStack checked parentStackStart params =

483− (\ paramNames ->

484− ( LocalVars [Final]

485− objectArrayType

486− [ VarDecl (VarDeclArray . VarId $ Ident "new_context")

487− (Just . InitExp $ mkContextCopy checked parentStackStart params)

488− ])

489− : ( map (\ (param, pos) ->

490− BlockStmt . ExpStmt $

491− Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])

492− (Lit $ Int (toInteger pos)))

493− EqualA

494− (ExpName param)) $ zip paramNames [parentStackStart..]

495− )

496− )

497− <$> mapM mkName params

498

461

499−mkContextCopy :: Bool -> Int -> [Name] -> Exp

500−mkContextCopy True parentStackStart params =

501− MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])

502− []

503− (Ident "clone")

504− []

505−mkContextCopy False parentStackStart params =

506− MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])

507− []

508− (Ident "copyOf")

509− [ ExpName $ J.Name [Ident "context"]

510− , MethodInv

511− $ TypeMethodCall (J.Name [Ident "Math"])

512− []

513− (Ident "max")

514− [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])

515− (Ident "length")

516− , Lit . Int $ toInteger (parentStackStart + length params)

517− ]

518− ]

519−

520reverseNameSpace :: J.Name -> J.Name

462reverseNameSpace :: J.Name -> J.Name

521reverseNameSpace (J.Name ids) =

463reverseNameSpace (J.Name ids) =

522 J.Name ((tail ids) ++ [head ids])

464 J.Name ((tail ids) ++ [head ids])

@@ -577,7 +519,16 @@ mkConsCase checked

577

519

578

520

579mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp

521mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp

522+mkCaseBinding True var parentStackStart params branchExpression =

523+ (\ branchExpression -> mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])

524+ ( (ExpName $ J.Name [Ident "context"])

525+ : (Lit $ Int (toInteger parentStackStart))

526+ : (mkCaseBindingDeconstruction var params)

527+ ))

528+ (branchExpression)

529+ )

530+ <$> mkExp branchExpression

580−mkCaseBinding checked var parentStackStart params branchExpression =

531+mkCaseBinding False var parentStackStart params branchExpression =

581 (\ bindingMethod ->

532 (\ bindingMethod ->

582 MethodInv $ PrimaryMethodCall

533 MethodInv $ PrimaryMethodCall

583 ( MethodInv $ PrimaryMethodCall (InstanceCreation []

534 ( MethodInv $ PrimaryMethodCall (InstanceCreation []

@@ -595,12 +546,14 @@ mkCaseBinding checked var parentStackStart params branchExpression =

595 (Ident "call")

546 (Ident "call")

596 []

547 []

597 )

548 )

598− <$> mkCaseBindingMethod checked parentStackStart params branchExpression

549+ <$> mkCaseBindingMethod parentStackStart params branchExpression

599−

600

550

551+mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]

552+mkCaseBindingDeconstruction var members =

553+ map (mkProjection var) ([0..(length members - 1)])

601

554

602−mkCaseBindingMethod :: Bool -> Int -> [Name] -> SExp -> Either String MemberDecl

555+mkCaseBindingMethod :: Int -> [Name] -> SExp -> Either String MemberDecl

603−mkCaseBindingMethod checked parentStackStart params branchExpression =

556+mkCaseBindingMethod parentStackStart params branchExpression =

604 (\ formalParams caseBindingStack branchExpression ->

557 (\ formalParams caseBindingStack branchExpression ->

605 MethodDecl [Final, Public]

558 MethodDecl [Final, Public]

606 []

559 []

@@ -612,12 +565,62 @@ mkCaseBindingMethod checked parentStackStart params branchExpression =

612 caseBindingStack ++

565 caseBindingStack ++

613 [BlockStmt . Return $ Just branchExpression]))

566 [BlockStmt . Return $ Just branchExpression]))

614 <$> mapM mkFormalParam params

567 <$> mapM mkFormalParam params

615− <*> mkBindingStack checked parentStackStart params

568+ <*> mkBindingStack False parentStackStart params

616 <*> mkBindingClosure branchExpression

569 <*> mkBindingClosure branchExpression

617

570

618−mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]

571+mkContextParam :: FormalParam

619−mkCaseBindingDeconstruction var members =

572+mkContextParam =

620− map (mkProjection var) ([0..(length members - 1)])

573+ FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))

574+

575+mkBindingClosure :: SExp -> Either String Exp

576+mkBindingClosure oldExp =

577+ (\ oldCall ->

578+ InstanceCreation []

579+ idrisClosureType

580+ [ ExpName $ J.Name [Ident "new_context"] ]

581+ (Just $ ClassBody [oldCall])

582+ )

583+ <$> mkClosureCall oldExp

584+

585+

586+mkBindingStack :: Bool -> Int -> [Name] -> Either String [BlockStmt]

587+mkBindingStack checked parentStackStart params =

588+ (\ paramNames ->

589+ ( LocalVars [Final]

590+ objectArrayType

591+ [ VarDecl (VarDeclArray . VarId $ Ident "new_context")

592+ (Just . InitExp $ mkContextCopy checked parentStackStart params)

593+ ])

594+ : ( map (\ (param, pos) ->

595+ BlockStmt . ExpStmt $

596+ Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])

597+ (Lit $ Int (toInteger pos)))

598+ EqualA

599+ (ExpName param)) $ zip paramNames [parentStackStart..]

600+ )

601+ )

602+ <$> mapM mkName params

603+

604+mkContextCopy :: Bool -> Int -> [Name] -> Exp

605+mkContextCopy True parentStackStart params =

606+ MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])

607+ []

608+ (Ident "clone")

609+ []

610+mkContextCopy False parentStackStart params =

611+ MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])

612+ []

613+ (Ident "copyOf")

614+ [ ExpName $ J.Name [Ident "context"]

615+ , MethodInv

616+ $ TypeMethodCall (J.Name [Ident "Math"])

617+ []

618+ (Ident "max")

619+ [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])

620+ (Ident "length")

621+ , Lit . Int $ toInteger (parentStackStart + length params)

622+ ]

623+ ]

621

624

622mkProjection :: LVar -> Int -> Exp

625mkProjection :: LVar -> Int -> Exp

623mkProjection var memberNr =

626mkProjection var memberNr =

@@ -1036,7 +1039,7 @@ mkExp (SApp True name args) =

1036 )

1039 )

1037 <$> mkMethodClosure name args

1040 <$> mkMethodClosure name args

1038mkExp (SLet var new old) =

1041mkExp (SLet var new old) =

1039− mkAnonymousLetBinding var old new

1042+ mkLet var old new

1040mkExp (SUpdate (Loc i) exp) =

1043mkExp (SUpdate (Loc i) exp) =

1041 (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))

1044 (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))

1042 EqualA

1045 EqualA