feat(#495): add foreign lpvm sizeof instr

Author: jimbxb

src/AST.hs

@@ -3632,6 +3632,7 @@ expOutputs (DisjExp pexp1 pexp2) = pexpListOutputs [pexp1,pexp2]
 expOutputs (Where _ pexp) = expOutputs $ content pexp
 expOutputs (CondExp _ pexp1 pexp2) = pexpListOutputs [pexp1,pexp2]
 expOutputs (Fncall _ _ _ args) = pexpListOutputs args
+expOutputs (ForeignFn "lpvm" "sizeof" _ (_:args)) = pexpListOutputs args
 expOutputs (ForeignFn _ _ _ args) = pexpListOutputs args
 expOutputs (CaseExp _ cases deflt) =
     pexpListOutputs $ maybe id (:) deflt (snd <$> cases)

src/Clause.hs

@@ -163,7 +163,7 @@ compileProc proc procID =
             gFlows  = makeGlobalFlows (zip [0..] params') $ procProtoResources proto
         let proto' = PrimProto (procProtoName proto) params' gFlows
         logClause $ "  comparams  : " ++ show params'
-        logClause $ "  globalFlows: " ++ show gFlows 
+        logClause $ "  globalFlows: " ++ show gFlows
         callSiteCount <- gets nextCallSiteID
         mSpec <- lift $ getModule modSpec
         let pSpec = ProcSpec mSpec procName procID Set.empty
@@ -287,6 +287,13 @@ compileSimpleStmt' call@(ProcCall func _ _ args) = do
                           . trustFromJust ("untyped higher-order term " ++ show fn) . maybeExpType $ content fn
             fn' <- compileHigherFunc fn
             return $ PrimHigher callSiteID fn' impurity' args'
+compileSimpleStmt' (ForeignCall "lpvm" "sizeof" flags [arg, out]) = do
+    repSize <- case content arg of
+        Typed _ ty _ -> typeRepSize . trustFromJust "sizeof with unkown typerep" <$> lift (lookupTypeRepresentation ty)
+        _ -> shouldnt $ "untyped in sizeof " ++ show arg
+    [out'] <- placedApply compileArg out
+    let size = if "bits" `elem` flags then repSize else (repSize + 7) `div` 8
+    return $ PrimForeign "llvm" "move" [] [ArgInt (fromIntegral size) intType, out']
 compileSimpleStmt' (ForeignCall lang name flags args) = do
     args' <- concat <$> mapM (placedApply compileArg) args
     return $ PrimForeign lang name flags args'
@@ -377,24 +384,24 @@ compileParam allFlows startVars endVars procName idx param@(Param name ty flow f
                 (shouldnt ("compileParam for input param " ++ show param
                             ++ " of proc " ++ show procName))
                 name startVars
-          gFlows 
-            | (isResourcefulHigherOrder ||| genericType) ty 
+          gFlows
+            | (isResourcefulHigherOrder ||| genericType) ty
             = emptyGlobalFlows{globalFlowsParams=USet.singleton inIdx}
             | otherwise = emptyGlobalFlows
     ]
-    ++ 
+    ++
     [PrimParam (PrimVarName name num) ty FlowOut ftype (ParamInfo False gFlows)
     | flowsOut flow
     , let num = Map.findWithDefault
                 (shouldnt ("compileParam for output param " ++ show param
                             ++ " of proc " ++ show procName))
                 name endVars
-          gFlows 
+          gFlows
             | isResourcefulHigherOrder ty = univGlobalFlows
             | genericType ty = emptyGlobalFlows{globalFlowsParams=UniversalSet}
             | otherwise = emptyGlobalFlows
     ]
-  where 
+  where
     inIdx = idx
     outIdx = if flowsIn flow then idx + 1 else idx
 

src/Flatten.hs

@@ -329,6 +329,15 @@ flattenStmt' stmt@(ProcCall func detism res args) pos d = do
     args' <- flattenStmtArgs args pos
     emit pos $ ProcCall func detism res args'
     flushPostponed
+flattenStmt' (ForeignCall "lpvm" "sizeof" flags args@(arg:_)) pos _ = do
+    let (arg', argPos) = unPlace arg
+    case innerExp arg' of
+        Var var flow _ | var /= "_" && flow /= ParamIn -> 
+            lift $ message Error "First argument to sizeof cannot be an out variable" argPos
+        _ -> return ()
+    args' <- flattenStmtArgs args pos
+    emit pos $ ForeignCall "lpvm" "sizeof" flags args'
+    flushPostponed
 flattenStmt' (ForeignCall lang name flags args) pos _ = do
     args' <- flattenStmtArgs args pos
     emit pos $ ForeignCall lang name flags args'
@@ -635,6 +644,9 @@ flattenExp (Fncall mod name bang exps) ty castFrom pos = do
         $ errmsg pos "function call cannot have preceding !"
     let stmtBuilder = ProcCall (First mod name Nothing) Det bang
     flattenCall stmtBuilder False ty castFrom pos exps
+flattenExp (ForeignFn "lpvm" "sizeof" flags (exp:exps)) ty castFrom pos = do
+    exp' <- flattenPExp exp
+    flattenCall (ForeignCall "lpvm" "sizeof" flags . (exp':)) True ty castFrom pos exps
 flattenExp (ForeignFn lang name flags exps) ty castFrom pos = do
     flattenCall (ForeignCall lang name flags) True ty castFrom pos exps
 flattenExp (Typed exp AnyType _) ty castFrom pos = do

src/Types.hs

@@ -2907,6 +2907,11 @@ checkLPVMArgs "cast" _ [old,new] stmt pos = return ()
 checkLPVMArgs "cast" _ [] stmt pos = return ()
 checkLPVMArgs "cast" _ args stmt pos =
     typeError (ReasonForeignArity "cast" (length args) 2 pos)
+checkLPVMArgs "sizeof" _ [thing,sz] stmt pos = 
+    reportErrorUnless (ReasonForeignArgRep "sizeof" 1 sz "integer" pos)
+                      (integerTypeRep sz)
+checkLPVMArgs "sizeof" _ args stmt pos =
+    typeError (ReasonForeignArity "sizeof" (length args) 2 pos)
 checkLPVMArgs name _ args stmt pos =
     typeError (ReasonBadForeign "lpvm" name pos)
 

wybelibs/wybe/machine_word.wybe

@@ -7,6 +7,6 @@ representation is address
 
 use wybe.int
 
-pub def word_size_bytes:int = 8
+pub def word_size_bytes:int = foreign lpvm sizeof(_:_)
 
-pub def word_size_bits:int = 8 * word_size_bytes
+pub def word_size_bits:int = foreign lpvm {bits} sizeof(_:_)