Add foreign proc def (#371)

* Added foreign proc def

* Ensure resource declaration order is maintained

* Require params be typed in foreign proc defs

* Add foreign proc def to WYBE.md

* Specify more on resources and modifiers

* Coalesce repeated resources into one; improve test case to cover all resource flow cases

Author: jimbxb

WYBE.md

@@ -736,7 +736,7 @@ Wybe also supports an alternative syntax for invoking procedures, functions, or
 constructors that puts the (first) argument first, and the procedure, function,
 or constructor name, with its other arguments, if any, second:
 
-> *arg*`^`*operation*(*other args*)
+> *arg*`^`*operation*`(`*other args*`)`
 
 and in the special case of operations taking only one argument:
 
@@ -2064,7 +2064,7 @@ so be careful to get the call right.
 
 The form of a foreign call is:
 
-> `foreign` *language* *function*(*arg*, *arg*, ...)
+> `foreign` *language* *function*`(`*arg*, *arg*, ...`)`
 
 where *language* is the name of the foreign language the function is written in,
 *function* is the name of the foreign function to call, and the *arg*s are the
@@ -2092,7 +2092,7 @@ Foreign calls may optionally specify *modifiers* to provide extra information
 useful to the Wybe compiler.  If modifiers are to be specified, they are written 
 after the *language* name:
 
-> `foreign` *language* `{`*modifiers*`}` *function*(*arg*, *arg*, ...)
+> `foreign` *language* `{`*modifiers*`}` *function*`(`*arg*, *arg*, ...`)`
 
 where *modifiers* is a comma-separate sequence of identifiers specifying this
 information.  Supported modifiers in foreign calls are:
@@ -2123,6 +2123,35 @@ and the less than test for integers is defined as
 pub def {test} (x:_ <  y:_) { foreign llvm {test} icmp_slt(x,y) }
 ```
 
+##### Foreign procedure definition short-hand
+
+For convenince, a short-hand syntax is provided to define a Wybe procedure to interface
+with a foriegn procedure. This syntax is as follows:
+
+> `def` `foreign` *language* *function*`(`*param*, *param*, ...`)`
+
+which is equivalent to defining the following:
+
+> `def` *function*`(`*param*, *param*, ...`)` `{` `foreign` *language* *function*`(`*param*, *param*, ...`)` `}`
+
+Note that all parameters must be typed.
+
+Resources can optionally be specified with a `use` clause, that follows the same syntax
+for a regular Wybe procedure definition. Resources are added as additonal arguments to 
+the foreign call after the other arguments, in the order specified in the source code.
+If resources are repeated in the `use` clause, they are added as multiple arguments in 
+the generated foreign call.
+
+Modifiers can also optionally be specified, with the syntax being identical to a Wybe 
+procedure definition, and are added to the foreign procedure call. 
+In addition, inlining (`inline`, `noinline`) can be specified for the for a 
+foreign procedure, but only inline/don't inline the generated Wybe procedure, and don't 
+apply to the generated foreign call.
+
+With both resources and modifiers, this would be as follows:
+
+> `def` `foreign` *language* `{` *modifiers* `}` *function*`(`*param*, *param*, ...`)` `use` *resources*
+
 
 #### Using LLVM instructions
 

src/AST.hs

@@ -179,9 +179,9 @@ data Item
      | ImportForeign [FilePath] OptPos
      | ImportForeignLib [Ident] OptPos
      | ResourceDecl Visibility ResourceName TypeSpec (Maybe (Placed Exp)) OptPos
-       -- The Bool in the next two indicates whether inlining is forced
      | FuncDecl Visibility ProcModifiers ProcProto TypeSpec (Placed Exp) OptPos
      | ProcDecl Visibility ProcModifiers ProcProto [Placed Stmt] OptPos
+     | ForeignProcDecl Visibility Ident ProcModifiers ProcProto OptPos
      | StmtDecl Stmt OptPos
      | PragmaDecl Pragma
      deriving (Generic, Eq)
@@ -2169,9 +2169,9 @@ univGlobalFlows = GlobalFlows UniversalSet UniversalSet UniversalSet
 -- In the case we have a higher order resourceful argument, we may not know
 -- exactly which global variables flow into or out of a procedure, and as such
 -- we take a conservative approach and assume all do.
-makeGlobalFlows :: [(ParameterID, PrimParam)] -> Set ResourceFlowSpec -> GlobalFlows
+makeGlobalFlows :: [(ParameterID, PrimParam)] -> [ResourceFlowSpec] -> GlobalFlows
 makeGlobalFlows params resFlows =
-    Set.fold addGlobalResourceFlows 
+    List.foldr addGlobalResourceFlows 
         (emptyGlobalFlows{globalFlowsParams=pFlows}) resFlows
   where
     pFlows = FiniteSet $ Set.fromList $ catMaybes $ List.map (uncurry paramFlow) params
@@ -2761,7 +2761,7 @@ data Constant = Int Int
 data ProcProto = ProcProto {
     procProtoName::ProcName,
     procProtoParams::[Placed Param],
-    procProtoResources::Set.Set ResourceFlowSpec
+    procProtoResources::[ResourceFlowSpec]
     } deriving (Eq, Generic)
 
 
@@ -3053,7 +3053,7 @@ data Exp
                -- these two must be the same.
       | Global GlobalInfo
       -- The following are eliminated during flattening
-      | AnonProc ProcModifiers [Param] [Placed Stmt] (Maybe VarDict) (Maybe (Set ResourceFlowSpec))
+      | AnonProc ProcModifiers [Param] [Placed Stmt] (Maybe VarDict) (Maybe [ResourceFlowSpec])
       | AnonFunc (Placed Exp)
       | AnonParamVar (Maybe Integer) FlowDirection
       | Where [Placed Stmt] (Placed Exp)
@@ -3758,7 +3758,14 @@ instance Show Item where
     ++ showOptPos pos
     ++ " {"
     ++ showBody 4 stmts
-    ++ "\n  }"
+    ++ "\n  }"  
+  show (ForeignProcDecl vis lang modifiers proto pos) =
+    visibilityPrefix vis
+    ++ "def foreign "
+    ++ lang ++ " "
+    ++ showProcModifiers' modifiers
+    ++ show proto
+    ++ showOptPos pos
   show (StmtDecl stmt pos) =
     showStmt 4 stmt ++ showOptPos pos
   show (PragmaDecl prag) =
@@ -3925,11 +3932,10 @@ instance Show TypeSpec where
 
 
 -- |Show the use declaration for a set of resources, if it's non-empty.
-showResources :: Set.Set ResourceFlowSpec -> String
+showResources :: [ResourceFlowSpec] -> String
 showResources resources
-  | Set.null resources = ""
-  | otherwise          = " use " ++ intercalate ", "
-                                    (List.map show $ Set.elems resources)
+  | List.null resources = ""
+  | otherwise           = " use " ++ intercalate ", " (List.map show resources)
 
 
 -- |How to show a proc prototype.

src/Builder.hs

@@ -1137,9 +1137,9 @@ buildMain :: [[ModSpec]] -> Compiler Item
 buildMain sccs = do
     logBuild "Generating main executable code"
     let cmdResource name = ResourceFlowSpec (ResourceSpec cmdLineModSpec name)
-    let mainRes = Set.fromList [cmdResource "argc" ParamIn,
-                                cmdResource "argv" ParamIn,
-                                cmdResource "exit_code" ParamOut]
+    let mainRes = [ cmdResource "argc" ParamIn
+                  , cmdResource "argv" ParamIn
+                  , cmdResource "exit_code" ParamOut]
     initPairs <- mapM sccInits sccs
     let initRes = concatMap fst initPairs
     let body = concatMap snd initPairs

src/Flatten.hs

@@ -66,23 +66,23 @@ flattenProcBody pd _ = do
                  $ List.map paramName
                  $ List.filter (flowsIn . paramFlow)
                  $ content <$> params
-        resources = Set.map (resourceName . resourceFlowRes)
+        resources = List.map (resourceName . resourceFlowRes)
                   $ procProtoResources proto
         ProcDefSrc body = procImpln pd
 
         detism = procDetism pd
         inlining = procInlining pd
         impurity = procImpurity pd
         variant = procVariant pd
-        resourceful = not $ Set.null resources
+        resourceful = not $ List.null resources
         mods = ProcModifiers detism inlining impurity variant resourceful
 
     logMsg Flatten
         $ "** Flattening def " ++ showProcModifiers' mods ++ show proto
             ++ " {" ++ showBody 4 body ++ "}"
     mapM_ (placedApply $ flip explicitTypeSpecificationWarning . paramType) params
 
-    (body',tmpCtr) <- flattenBody body (inParams `Set.union` resources) detism
+    (body',tmpCtr) <- flattenBody body (inParams `Set.union` Set.fromList resources) detism
 
     return pd{procTmpCount = tmpCtr, procImpln = ProcDefSrc body'}
 
@@ -647,7 +647,7 @@ flattenExp (Typed exp ty castFrom) _ _ pos = do
 
 -- | Flatten something, and produce an anonymous procedure from the resultant flattened
 -- statements
-flattenAnon :: ProcModifiers -> (Maybe VarDict) -> (Maybe (Set ResourceFlowSpec))
+flattenAnon :: ProcModifiers -> (Maybe VarDict) -> (Maybe [ResourceFlowSpec])
             -> TypeSpec -> Maybe TypeSpec -> OptPos
             -> Flattener () -> Flattener (Placed Exp)
 flattenAnon mods clsd res ty castFrom pos inner = do

src/Normalise.hs

@@ -111,6 +111,28 @@ normaliseItem (FuncDecl vis mods (ProcProto name params resources)
                  [result, varSet outputVariableName `maybePlace` pos])
               pos]
         pos)
+normaliseItem (ForeignProcDecl vis lang mods proto@(ProcProto name params resources) pos) = do
+    when (mods{modifierImpurity=Pure, modifierDetism=Det, modifierInline=MayInline} /= defaultProcModifiers)
+        $ errmsg pos
+        $ "Foreign procedure declaration of " ++ name
+            ++ " has illegal procedure modifiers. Only purity, determinism, and inlining can be specified."
+    mapM_ ((\(Param{paramType=ty, paramName=name}, pos) -> do
+            when (ty == AnyType)
+                $ errmsg pos
+                $ "Foreign procedure declaration parameters must be typed, but " ++ name ++ " is untyped."
+        ) . unPlace) params
+
+    normaliseItem
+        (ProcDecl vis mods proto
+            [maybePlace (ForeignCall lang name mods' exps) pos] pos)
+  where
+    mods' = List.filter (not . List.null) 
+                [ impurityName (modifierImpurity mods)
+                , determinismName (modifierDetism mods) ]
+    exps = List.map (uncurry (flip rePlace . paramToVar) . unPlace) params
+        ++ List.map (\(ResourceFlowSpec rs@(ResourceSpec _ r) dir) ->
+                        Var r dir (Resource rs) `maybePlace` pos)
+                    resources
 normaliseItem item@ProcDecl{} = do
     logNormalise $ "Recording proc without flattening:" ++ show item
     addProc 0 item
@@ -288,7 +310,7 @@ validateModuleName what pos name =
 
 -- |Check that the specified module name is valid, reporting and error if not.
 validateModSpec :: OptPos -> ModSpec -> Compiler ()
-validateModSpec pos = mapM_ (validateModuleName "module" pos) 
+validateModSpec pos = mapM_ (validateModuleName "module" pos)
 
 
 -- | Information about a non-constant constructor
@@ -400,7 +422,7 @@ nonConstCtorInfo (vis, placedProto) tag = do
     logNormalise $ "Analysing non-constant ctor "
                    ++ show tag ++ ": " ++ show placedProto
     let (proto,pos) = unPlace placedProto
-    unless (Set.null $ procProtoResources proto)
+    unless (List.null $ procProtoResources proto)
       $ shouldnt $ "Constructor with resources: " ++ show placedProto
     let name   = procProtoName proto
     let params = procProtoParams proto
@@ -470,7 +492,7 @@ normaliseModMain modSCC = do
 -- assumes that all resource initialisations have already been completed, and
 -- all are permitted to be modified by the initialisation code, so all
 -- visible initialised resources flow both in and out.
-initResources :: [ModSpec] -> Compiler (Set ResourceFlowSpec)
+initResources :: [ModSpec] -> Compiler [ResourceFlowSpec]
 initResources modSCC = do
     thisMod <- getModule modSpec
     mods <- getModuleImplementationField (Map.keys . modImports)
@@ -489,7 +511,7 @@ initResources modSCC = do
     -- because that would overwrite them.
     let cmdlineResources =
             if cmdLineModSpec == thisMod
-            then let cmdline = ResourceSpec cmdLineModSpec 
+            then let cmdline = ResourceSpec cmdLineModSpec
                  in [ResourceFlowSpec (cmdline "argc") ParamInOut
                     ,ResourceFlowSpec (cmdline "argv") ParamInOut]
             else []
@@ -498,7 +520,7 @@ initResources modSCC = do
                          <$> Set.toList visibleInitSet)
     logNormalise $ "In initResources for module " ++ showModSpec thisMod
                    ++ ", resources = " ++ show resources
-    return (Set.fromList resources)
+    return resources
 
 
 
@@ -538,7 +560,7 @@ constCtorItems typeSpec ((vis, placedProto), num) =
         constName = procProtoName proto
     in [ProcDecl vis (inlineModifiers (ConstructorProc constName) Det)
         (ProcProto constName
-            [Param outputVariableName typeSpec ParamOut Ordinary `maybePlace` pos] Set.empty)
+            [Param outputVariableName typeSpec ParamOut Ordinary `maybePlace` pos] [])
         [lpvmCastToVar (castTo (iVal num) typeSpec) outputVariableName] pos
        ]
 
@@ -652,7 +674,7 @@ constructorItems vis ctorName typeSpec params fields size tag tagLimit pos =
         (ProcProto ctorName
             ((placedApply (\p -> maybePlace p {paramFlow=ParamIn, paramFlowType=Ordinary}) <$> params)
              ++ [Param outputVariableName typeSpec ParamOut Ordinary `maybePlace` pos])
-            Set.empty)
+            [])
         -- Code to allocate memory for the value
         ([maybePlace (ForeignCall "lpvm" "alloc" []
           [Unplaced $ iVal size,
@@ -702,7 +724,7 @@ deconstructorItems uniq vis ctorName typeSpec params numConsts numNonConsts tag
         (ProcProto ctorName
          ((contentApply (\p -> p {paramFlow=ParamOut, paramFlowType=Ordinary}) <$> params)
           ++ [Param outputVariableName typeSpec ParamIn Ordinary `maybePlace` pos])
-         Set.empty)
+         [])
         -- Code to check we have the right constructor
         (tagCheck pos numConsts numNonConsts tag tagBits tagLimit
             (Just size) outputVariableName
@@ -810,7 +832,7 @@ unboxedConstructorItems vis ctorName typeSpec tag nonConstBit fields pos =
                 ([Param name paramType ParamIn Ordinary `maybePlace` pPos
                  | FieldInfo name pPos _ paramType _ _ _ <- fields]
                   ++ [Param outputVariableName typeSpec ParamOut Ordinary `maybePlace` pos])
-                Set.empty
+                []
     in [ProcDecl vis (inlineModifiers (ConstructorProc ctorName) Det) proto
          -- Initialise result to 0
         ([ForeignCall "llvm" "move" []
@@ -863,7 +885,7 @@ unboxedDeconstructorItems vis uniq ctorName recType numConsts numNonConsts tag
          (List.map (\(FieldInfo n pPos _ fieldType _ _ _) -> Param n fieldType ParamOut Ordinary `maybePlace` pPos)
           fields
           ++ [Param outputVariableName recType ParamIn Ordinary `maybePlace` pos])
-         Set.empty)
+         [])
          -- Code to check we have the right constructor
         (tagCheck pos numConsts numNonConsts tag tagBits (wordSizeBytes-1) Nothing
           outputVariableName
@@ -965,13 +987,13 @@ getterSetterItems numConsts numNonConsts recType field infos = do
         [-- The getter:
         ProcDecl fieldVis (setInline inline $ inlineModifiers (GetterProc field fieldType) detism)
         (ProcProto field [Param recName recType ParamIn Ordinary `maybePlace` pos,
-                          Param outputVariableName fieldType ParamOut Ordinary `maybePlace` pos] Set.empty)
+                          Param outputVariableName fieldType ParamOut Ordinary `maybePlace` pos] [])
         getBody
         pos,
         -- The setter:
         ProcDecl fieldVis (setInline inline $ inlineModifiers (SetterProc field fieldType) detism)
         (ProcProto field [Param recName recType ParamInOut Ordinary `maybePlace` pos,
-                          Param fieldName fieldType ParamIn Ordinary `maybePlace` pos] Set.empty)
+                          Param fieldName fieldType ParamIn Ordinary `maybePlace` pos] [])
         setBody
         pos]
 
@@ -1008,7 +1030,7 @@ implicitEquality pos typespec consts nonconsts rep = do
     else do
       let eqProto = ProcProto "=" [Param leftName typespec ParamIn Ordinary `maybePlace` pos,
                                    Param rightName typespec ParamIn Ordinary `maybePlace` pos]
-                    Set.empty
+                    []
       let (body,inline) = equalityBody pos consts nonconsts rep
       return [ProcDecl Public (setInline inline
                                $ setDetism SemiDet defaultProcModifiers)
@@ -1024,7 +1046,7 @@ implicitDisequality pos typespec consts nonconsts _ = do
     else do
       let neProto = ProcProto "~=" [Param leftName typespec ParamIn Ordinary `maybePlace` pos,
                                      Param rightName typespec ParamIn Ordinary `maybePlace` pos]
-                    Set.empty
+                    []
       let neBody = [maybePlace (Not $
                         ProcCall (First [] "=" Nothing) SemiDet False
                             [varGetTyped leftName typespec `maybePlace` pos,