@@ -300,6 +300,9 @@ mkIdentifier (UN name) =
300300 cleanReserved "fputStr" = "_fputStr"
301301 cleanReserved "fileEOF" = "_fileEOF"
302302 cleanReserved "isNull" = "_isNull"
303+ cleanReserved "idris_K" = "_idris_K"
304+ cleanReserved "idris_flipK" = "_idris_flipK"
305+ cleanReserved "idris_assignStack" = "_idris_assignStack"
303306
304307 cleanReserved x = x
305308
@@ -376,19 +379,29 @@ mkDecl ((NS n (ns:nss)), decl) =
376379 <$> mkIdentifier (UN ns)
377380 <*> mkClassBody [(NS n nss, decl)]
378381mkDecl (_, SFun name params stackSize body) =
379− (\ name params cont ->
382+ (\ name params paramNames methodBody ->
380383 MemberDecl $ MethodDecl [Public, Static]
381384 []
382385 (Just . RefType $ ClassRefType objectType)
383386 name
384387 params
385388 []
386− (MethodBody . Just $ Block [ BlockStmt . Return . Just . MethodInv $
387− PrimaryMethodCall cont [] (Ident "call") []])
389+ (MethodBody . Just $ Block
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+ )
388400 )
389401 <$> mkIdentifier name
390402 <*> mapM mkFormalParam params
391− <*> mkClosure params stackSize body
403+ <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
404+ <*> mkExp body
392405
393406
394407mkClosure :: [Name] -> Int -> SExp -> Either String Exp
@@ -424,99 +437,28 @@ mkStackInit params stackSize =
424437 ++ (replicate (stackSize) (InitExp $ Lit Null)))
425438 <$> mapM mkName params
426439
427−mkAnonymousLetBinding :: LVar -> SExp -> SExp -> Either String Exp
428−mkAnonymousLetBinding var oldExp newExp =
429− (\ bindingMethod newExp ->
430− MethodInv $ PrimaryMethodCall
431− ( MethodInv $ PrimaryMethodCall ( InstanceCreation []
432− objectType
433− []
434− (Just $ ClassBody [MemberDecl $ bindingMethod])
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
454−mkLetBindingMethod (Loc i) oldExp =
455− (\ param bindingStack oldCont ->
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"] ]
476− (Just $ ClassBody [oldCall])
440+mkK :: Exp -> Exp -> Exp
441+mkK result drop =
442+ MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
443+
444+mkFlipK :: Exp -> Exp -> Exp
445+mkFlipK drop result =
446+ MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
447+
448+mkLet :: LVar -> SExp -> SExp -> Either String Exp
449+mkLet (Loc pos) oldExp newExp =
450+ (\ oldExp newExp ->
451+ mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
452+ (Lit $ Int (toInteger pos)))
453+ EqualA
454+ newExp
455+ )
456+ oldExp
477457 )
478− <$> mkClosureCall oldExp
479−
458+ <$> mkExp oldExp
459+ <*> mkExp newExp
480460
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
498461
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−
520462reverseNameSpace :: J.Name -> J.Name
521463reverseNameSpace (J.Name ids) =
522464 J.Name ((tail ids) ++ [head ids])
@@ -577,7 +519,16 @@ mkConsCase checked
577519
578520
579521mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> Either String Exp
580−mkCaseBinding checked var parentStackStart params branchExpression =
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
531+mkCaseBinding False var parentStackStart params branchExpression =
581532 (\ bindingMethod ->
582533 MethodInv $ PrimaryMethodCall
583534 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
@@ -595,12 +546,14 @@ mkCaseBinding checked var parentStackStart params branchExpression =
595546 (Ident "call")
596547 []
597548 )
598− <$> mkCaseBindingMethod checked parentStackStart params branchExpression
599−
549+ <$> mkCaseBindingMethod parentStackStart params branchExpression
600550
551+mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]
552+mkCaseBindingDeconstruction var members =
553+ map (mkProjection var) ([0..(length members - 1)])
601554
602−mkCaseBindingMethod :: Bool -> Int -> [Name] -> SExp -> Either String MemberDecl
603−mkCaseBindingMethod checked parentStackStart params branchExpression =
555+mkCaseBindingMethod :: Int -> [Name] -> SExp -> Either String MemberDecl
556+mkCaseBindingMethod parentStackStart params branchExpression =
604557 (\ formalParams caseBindingStack branchExpression ->
605558 MethodDecl [Final, Public]
606559 []
@@ -612,12 +565,62 @@ mkCaseBindingMethod checked parentStackStart params branchExpression =
612565 caseBindingStack ++
613566 [BlockStmt . Return $ Just branchExpression]))
614567 <$> mapM mkFormalParam params
615− <*> mkBindingStack checked parentStackStart params
568+ <*> mkBindingStack False parentStackStart params
616569 <*> mkBindingClosure branchExpression
617570
618−mkCaseBindingDeconstruction :: LVar -> [Name] -> [Exp]
619−mkCaseBindingDeconstruction var members =
620− map (mkProjection var) ([0..(length members - 1)])
571+mkContextParam :: FormalParam
572+mkContextParam =
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+ ]
621624
622625mkProjection :: LVar -> Int -> Exp
623626mkProjection var memberNr =
@@ -1036,7 +1039,7 @@ mkExp (SApp True name args) =
10361039 )
10371040 <$> mkMethodClosure name args
10381041mkExp (SLet var new old) =
1039− mkAnonymousLetBinding var old new
1042+ mkLet var old new
10401043mkExp (SUpdate (Loc i) exp) =
10411044 (\ rhs -> Assign (ArrayLhs $ ArrayIndex (contextArray) (Lit $ Int (toInteger i)))
10421045 EqualA