Merge branch 'master' of github.com:edwinb/Idris2 into fully-abstract-records

Ohad Kammar committed 6 years ago

Commit f7775312 parents 1fcac7a 884d4ad8 files · +17 −18Browse files

Showing the changes to src (8 of 8 files). Show all

Unified · Split

8 files

src/Compiler/CompileExpr.idr +0 −5
src/Compiler/Inline.idr +1 −1
src/Compiler/Scheme/Chez.idr +6 −1
src/Compiler/Scheme/Common.idr +3 −3
src/Compiler/Scheme/Racket.idr +6 −2
src/Core/TTC.idr +0 −1
src/TTImp/ProcessData.idr +0 −4
src/Utils/Binary.idr +1 −1

                    pure $ natHack res
 mutual
-  -- In the below, treat %World, and newtypes, as default cases
   conCases : {auto c : Ref Ctxt Defs} ->
              NameTags -> Name -> List (CaseAlt vars) ->
              Core (List (CConAlt vars))
                NameTags -> Name -> List (CaseAlt vars) ->
                Core (List (CConstAlt vars))
   constCases tags n [] = pure []
-  constCases tags n (ConstCase WorldVal sc :: ns)
-      = constCases tags n ns
   constCases tags n (ConstCase x sc :: ns)
       = pure $ MkConstAlt x !(toCExpTree tags n sc) ::
                     !(constCases tags n ns)
   getDef fc scr tags n [] = pure Nothing
   getDef fc scr tags n (DefaultCase sc :: ns)
       = pure $ Just !(toCExpTree tags n sc)
-  getDef fc scr tags n (ConstCase WorldVal sc :: ns)
-      = pure $ Just !(toCExpTree tags n sc)
   getDef {vars} fc scr tags n (ConCase x tag args sc :: ns)
       = do defs <- get Ctxt
            case !(lookupDefExact x (gamma defs)) of

src/Compiler/Inline.idr+1−1

@@ -190,7 +190,7 @@ mutual · 189 unmodified lines
190	\| Nothing => pure (unload stk (CRef fc n))	190	\| Nothing => pure (unload stk (CRef fc n))
191	let arity = getArity def	191	let arity = getArity def
192	if (Inline `elem` flags gdef) && (not (n `elem` rec))	192	if (Inline `elem` flags gdef) && (not (n `elem` rec))
193	then do ap <- tryApply (n :: rec) stk env def	193	then do ap <- tryApply (n :: rec) stk env def
194	pure $ maybe (unloadApp arity stk (CRef fc n)) id ap	194	pure $ maybe (unloadApp arity stk (CRef fc n)) id ap
195	else pure $ unloadApp arity stk (CRef fc n)	195	else pure $ unloadApp arity stk (CRef fc n)
196	eval {vars} {free} rec env [] (CLam fc x sc)	196	eval {vars} {free} rec env [] (CLam fc x sc)

src/Compiler/Scheme/Chez.idr+6−1

     applyLams n (Nothing :: as) = applyLams ("(" ++ n ++ " #f)") as
     applyLams n (Just a :: as) = applyLams ("(" ++ n ++ " " ++ a ++ ")") as
+    getVal : String -> String
+    getVal str = "(vector-ref " ++ str ++ "2)"
     mkFun : List CFType -> CFType -> String -> String
     mkFun args ret n
         = let argns = mkNs 0 args in
               "(lambda (" ++ showSep " " (mapMaybe id argns) ++ ") " ++
-              (applyLams n argns ++ ")")
+              (case ret of
+                    CFIORes _ => getVal (applyLams n argns) ++ ")"
+                    _ => applyLams n argns ++ ")")
     notWorld : CFType -> Bool
     notWorld CFWorld = False

src/Compiler/Scheme/Common.idr+3−3

src/Compiler/Scheme/Racket.idr+6−2

     applyLams n (Just (a, ty) :: as)
         = applyLams ("(" ++ n ++ " " ++ cToRkt ty a ++ ")") as
+    getVal : CFType -> String -> String
+    getVal ty str = rktToC ty ("(vector-ref " ++ str ++ "2)")
     mkFun : List CFType -> CFType -> String -> String
     mkFun args ret n
         = let argns = mkNs 0 args in
-              "(lambda (" ++ showSep " " (map fst (mapMaybe id argns)) ++ ") " ++
+              (case ret of
-              (applyLams n argns ++ ")")
+                    CFIORes rt => getVal rt (applyLams n argns) ++ ")"
+                    _ => applyLams n argns ++ ")")
     notWorld : CFType -> Bool
     notWorld CFWorld = False

src/Core/TTC.idr+0−1

@@ -973,4 +973,3 @@ Core.Context.decode gam idx update (Coded bin) · 972 unmodified lines
973	when update $ coreLift $ writeArray arr idx (Decoded def')	973	when update $ coreLift $ writeArray arr idx (Decoded def')
974	pure def'	974	pure def'
975	Core.Context.decode gam idx update (Decoded def) = pure def	975	Core.Context.decode gam idx update (Decoded def) = pure def
976

src/TTImp/ProcessData.idr+0−4

 getRelevantArg defs i rel (NBind fc _ (Pi Rig0 _ _) sc)
     = getRelevantArg defs (1 + i) rel
            !(sc defs (toClosure defaultOpts [] (Erased fc False)))
--- %World is never inspected, so might as well be deleted from data types
-getRelevantArg defs i rel (NBind fc _ (Pi _ _ (NPrimVal _ WorldType)) sc)
-    = getRelevantArg defs (1 + i) rel
-           !(sc defs (toClosure defaultOpts [] (Erased fc False)))
 getRelevantArg defs i Nothing (NBind fc _ (Pi _ _ _) sc) -- found a relevant arg
     = getRelevantArg defs (1 + i) (Just i)
            !(sc defs (toClosure defaultOpts [] (Erased fc False)))

src/Utils/Binary.idr+1−1

@@ -114,7 +114,7 @@ initBinaryS s · 113 unmodified lines
114	extendBinary : Int -> Binary -> Core Binary	114	extendBinary : Int -> Binary -> Core Binary
115	extendBinary need (MkBin buf l s u)	115	extendBinary need (MkBin buf l s u)
116	= do let newsize = s * 2	116	= do let newsize = s * 2
117	let s' = if newsize < need	117	let s' = if (newsize - l) < need
118	then newsize + need	118	then newsize + need
119	else newsize	119	else newsize
120	Just buf' <- coreLift $ resizeBuffer buf s'	120	Just buf' <- coreLift $ resizeBuffer buf s'

Merge branch 'master' of github.com:edwinb/Idris2 into fully-abstract-records

Keyboard shortcuts

General

Issues and pull requests

Issues, pull requests and Inbox

Repository code

@@ -234,7 +234,7 @@ toPrim pn = Unknown pn · 233 unmodified lines
234		234
235	export	235	export
236	mkWorld : String -> String	236	mkWorld : String -> String
237	mkWorld res = res -- MkIORes is a newtype now! schConstructor 0 ["#f", res, "#f"] -- MkIORes	237	mkWorld res = schConstructor 0 ["#f", res, "#f"] -- MkIORes
238		238
239	schConstant : (String -> String) -> Constant -> String	239	schConstant : (String -> String) -> Constant -> String
240	schConstant _ (I x) = show x	240	schConstant _ (I x) = show x
@@ -346,11 +346,11 @@ parameters (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String, · 105 unmodified lines
346	= pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i fn) ++")) "	346	= pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i fn) ++")) "
347	++ !(readArgs i args) ++ ")")	347	++ !(readArgs i args) ++ ")")
348	schExtCommon i PutStr [arg, world]	348	schExtCommon i PutStr [arg, world]
349	= pure $ "(display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit	349	= pure $ "(begin (display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) ++ ")" -- code for MkUnit
350	schExtCommon i GetStr [world]	350	schExtCommon i GetStr [world]
351	= pure $ mkWorld "(blodwen-get-line (current-input-port))"	351	= pure $ mkWorld "(blodwen-get-line (current-input-port))"
352	schExtCommon i PutChar [arg, world]	352	schExtCommon i PutChar [arg, world]
353	= pure $ "(display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit	353	= pure $ "(begin (display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) ++ ")" -- code for MkUnit
354	schExtCommon i GetChar [world]	354	schExtCommon i GetChar [world]
355	= pure $ mkWorld "(blodwen-get-char (current-input-port))"	355	= pure $ mkWorld "(blodwen-get-char (current-input-port))"
356	schExtCommon i FileOpen [file, mode, bin, world]	356	schExtCommon i FileOpen [file, mode, bin, world]